[[20080919131054]]　『ランダムで並び替える方法』（カルロ）　ページの最後に飛ぶ

『ランダムで並び替える方法』（カルロ）

 Excel2002,WindowsXP
 こんにちわ。何時もお世話になります。
 答えと問題があります。マクロ処理ｷる度に答えを並び替えたいのです。
 例えば、

 ＜リストシート＞
       A           B         C        D        E        F
 1  　問題　 |　 答え１　　答え２　 答え３　 答え４   答え番号
 -------------------------------------------------------------
 2   問題１  |     A        B        C                   １
 3   問題２  |     AA       BB       CC        DD        ４
 4   問題３  |     CCC      AAA      DDD      FFF　　　　２

 このように問題(A列)があって答え１～４があり答え番号(F列)があります。
 マクロ処理する度に全ての問題の答えをランダムに並べかえたいのです。
 たとえば、(B2:E2)までを並べ替える。
 答え番号も同時に変えるには、どうすればよいのでしょうか？
 関数を利用してできるでしょうか？教えて下さい。
 よろしくお願いします。

https://www.excel.studio-kazu.jp/cgi-bin/estindex/estseek2.cgi?phrase=%E6%96%87%E5%AD%97+%E3%83%A9%E3%83%B3%E3%83%80%E3%83%A0&perpage=10&attr=&order=&clip=-1&navi=0こんな感じでうまく行きますか？

 (ROUGE)
'----
Sub Carlo()
Dim i As Long, x, ans
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    x = Range("B" & i).Resize(, 4).SpecialCells(xlCellTypeConstants, 23).Value
    ans = WorksheetFunction.Index(Range("B" & i).Resize(, 4), Range("F" & i).Value)
    Mazemaze x
    Range("B" & i).Resize(, UBound(x, 2)).Value = x
    Range("F" & i).Value = WorksheetFunction.Match(ans, Range("B" & i).Resize(, UBound(x, 2)), 0)
Next
End Sub
Private Sub Mazemaze(x)
Dim tbl, i As Integer
ReDim tbl(1 To UBound(x, 2), 1 To 2)
Randomize
For i = 1 To UBound(tbl, 1)
    tbl(i, 1) = Int(Rnd * 10000)
    tbl(i, 2) = x(1, i)
Next
UQS tbl, 1, LBound(tbl, 1), UBound(tbl, 1)
For i = 1 To UBound(tbl, 1)
    x(1, i) = tbl(i, 2)
Next
End Sub
Private Sub UQS(ByRef tbl, ky As Integer, ByVal tp As Long, ByVal bt As Long)
    Dim i As Long, j As Long, k As Integer, m As Long, buf
    i = tp: j = bt: m = (tbl(i, ky) + tbl(j, ky)) \ 2
    Do
        Do While tbl(i, ky) < m
            i = i + 1
        Loop
        Do While tbl(j, ky) > m
            j = j - 1
        Loop
        If i >= j Then Exit Do
        For k = LBound(tbl, 2) To UBound(tbl, 2)
            buf = tbl(i, k): tbl(i, k) = tbl(j, k): tbl(j, k) = buf
        Next
        i = i + 1: j = j - 1
    Loop
    If tp < i - 1 Then UQS tbl, ky, tp, i - 1
    If bt > j + 1 Then UQS tbl, ky, j + 1, bt
End Sub

 ROUGEさん回答ありがとうございます。
 Carloマクロを実行してみました。ある程度まで動くのですが途中で、

 Sub Carlo()
 Dim i As Long, x, ans
 For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
     x = Range("B" & i).Resize(, 4).SpecialCells(xlCellTypeConstants, 23).Value
 ここのところで、
 >x = Range("B" & i).Resize(, 4).SpecialCells(xlCellTypeConstants, 23).Value
 止まって「実行時エラー1004：該当するセルが見つかりません」がでます。
 並べ替えと回答番号は、並べ変わっています。
 ３行並べ替えた後に４行目になったら並べ替えデータがないので、実行時エラーがでているようです。
 このエラーを出さないようにするには、どうしたらよいのでしょうか？
 マクロの内容が難しくてどこを変更、追加すればよいのかわかりません。
 お手数をお掛けしますが教えて下さい。よろしくお願いします（カルロ）

 メインプロシジャを下記と差し替えたらどうなりますか？(ROUGE)
'----
Sub Carlo()
Dim i As Long, x, ans
On Error Resume Next
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    x = Range("B" & i).Resize(, 4).SpecialCells(xlCellTypeConstants, 23).Value
    If Err.Number <> 0 Then
        Err.Clear
    Else
        ans = WorksheetFunction.Index(Range("B" & i).Resize(, 4), Range("F" & i).Value)
        Mazemaze x
        Range("B" & i).Resize(, UBound(x, 2)).Value = x
        Range("F" & i).Value = WorksheetFunction.Match(ans, Range("B" & i).Resize(, UBound(x, 2)), 0)
    End If
Next
On Error GoTo 0
End Sub

 ROUGEさん回答ありがとうございます。
 今度は、バッチリできました。お手数をおかけしました。
 内容がとても難しくてよくわかりませんが、理解できるように努力します。
 また、わからないところがありましたら教えて下さい。
 よろしくお願いします（カルロ）

 本当ですか？
 さっきのコードでは不具合でそうなので、ちょこっと修正しています。
 念のため、差し替えしてください。。。
 (ROUGE) #見ているといいのですが。。。

 どなたか？わかりませんが、回答有り難うございます。
 >ちょこっと修正しています
 差し替えしました。 エラーもなく動きました。
 有り難うございます。

 ついでにもう１つ質問してもよいですか？
 問題数が5問まである場合を想定してマクロを動かしてみましたが
 正しい解答が入力されませんでした。
 どこの記述をどのように変更したらよいのでしょうか？
 また、表は、わかりやすいようにA1から入力していますが、もし、C3に"問題"を
 書いているとすると上記　マクロは、どこを修正すればよいのでしょうか？
 ステップ実行で１つずつ実行してみましたがよくわかりません。
 難しすぎる。教えて下さい。よろしくお願いします（カルロ）

 ＜リストシート＞
       C           D         E        F        G         H       I
 3  　問題　 |　 答え１　　答え２　 答え３　 答え４   答え５  答え番号
 -------------------------------------------------------------
 4   問題１  |     A        B        C                          １
 5   問題２  |     AA       BB       CC        DD       EE      ５
 6   問題３  |     CCC      AAA      DDD      FFF　　　　       ２

 えっと、ふたつ上の書き込みは私です＾＾；
 署名していましたが、見落とされましたかね？

 さて、ご質問の件ですが、サブプロシジャはそのままで大丈夫です。
 メインプロシジャだけ見てみましょう。
'----------------
Sub Carlo()
Dim i As Long, x, ans
On Error Resume Next                                 'エラーが出ても処理を継続する
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row   '変数 i を2からA列の最終行番号までのループ処理 (1)
    x = Range("B" & i).Resize(, 4).SpecialCells(xlCellTypeConstants, 23).Value
                                                     'B:E列で何かが入っているセルの値を配列xに取り込む (2)
    If Err.Number <> 0 Then                          'もしエラーが発生していたら、
        Err.Clear                                    'エラーをクリアする。
    Else                                             'エラーが発生していなかったら、
        ans = WorksheetFunction.Index(Range("B" & i).Resize(, 4), Range("F" & i).Value)
                                                     'index関数を使って、変数ansにその行の答えを代入 (3)
        Mazemaze x                                   '配列xをランダムに並び替え
        Range("B" & i).Resize(, UBound(x, 2)).Value = x
                                                     '並び替えたものを元の場所に貼り付ける (4)
        Range("F" & i).Value = WorksheetFunction.Match(ans, Range("B" & i).Resize(, UBound(x, 2)), 0)
                                                     '答えの場所にMatch関数を使って数値を入れ込む (5)
    End If                                           '「もし」は終わり
Next                                                 'カウンタを増やす
On Error GoTo 0                                      '「エラーでも継続」は終わり
End Sub
'----------------
　
で、カルロさんの再質問を見ると、もとの表と異なる点が3つあります。
　
１．始まりの行番号が 1 --> 3
２．始まりの列番号が 1(A) --> 3(C)
３．答えの選択肢が 4 --> 5
　
で、上記3つの変更点に対応するには、上記メインプロシジャの説明に記載した(1)～(5)の太字箇所を変更する必要があります。
　
(ROUGE)

 ROUGEさん回答ありがとうございました。
 丁寧な解説で少しですが、理解できました。
 処理もうまくゆきました。
 すごく頭いいですね。こんなに簡潔にマクロ処理できるなんて。。すごい。
 配列を利用しているのですね。私、配列とかは、難しいのであまり使いません。
 でも配列を利用するといろいろな処理に柔軟に対応できますね。
 難しいけど勉強する価値はありますね。

 すみません。もう１つ質問してもよいですか？
 たとえば、
      A           B         C        D        E        F          G
 1  　問題　 |　 答え１　　答え２　 答え３　 答え４   答え番号　コメント
 ---------------------------------------------------------------------------
 2   問題１  |     A        B        C                   1     正解は1番です。
 3   問題２  |     AA       BB       CC        DD        4     正解は4番です。

 G2、G3に”正解は？番です。”と入力する時、文字は、変わらないのですが、数字
 だけ変更することはできますか？
 Range("''F''" & i).Value = WorksheetFunction.Match(ans, Range("''B''" & i).Resize(, UBound(x, 2)), 0)

 この記述の次に入力するのでしょうか？どんな記述を入力したらよいのですか？
 教えて下さい（カルロ）

 関数を入力しておけば良いのでは？

 G2=TEXT(F2,"正解は0番です。")

 (ROUGE)

 ROUGEさん回答ありがとうございます。
 了解しました。
 もし、回答の文字数が５０文字以上ある場合も対応できますか？
 >x = Range("B" & i).Resize(, 4).SpecialCells(xlCellTypeConstants, 23).Value
 マクロの５行目の記述で最後の方に２３という数字が入っていますが、これは何を意味するのですか？
 教えて下さい（カルロ）

 多分、これと同じ意味です。。。

 xlLogical + xlNumbers + xlTextValues

 (ROUGE)

 回答ありがとうございます。上記の意味よくわかりませんが、
 今　処理してみましたが回答文字数が多くても問題ないようです。
 わからないことがたくさんです。勉強不足ですみません。
 お手数をおかけしました。助かりました。
 有難うございます。今後とも　よろしくお願いします（カルロ）

 おはようございます。いつもお世話になります。
 ROUGEさんより教えていただきました、上記マクロについて１つ教えて下さい。
 実は、答えが”文字型の数字”を並び替える場合、並び替えがうまくいかず答えが
 間違ってしまいます。”文字型の数字”を”数値型”に訂正すると正解が表示されます。
 ”文字型の数字”でも正解がでるようにする方法はありませんか？
 お手数をおかけしますがよろしくお願いします（カルロ）

 Range("F" & i).Value
 の部分を
 CInt(Range("F" & i).Value)
 にしてみてはどうですか。
 (Mook)

 Mookさん回答有難うございました。
 この部分を"CInt(Range("F" & i).Value)"に訂正したら、"コンパイルエラー：修正候補：識別子"
 というエラーがでて
 CInt(Range("F" & i).Value) = WorksheetFunction.Match(ans, Range("B" & i).Resize(, UBound(x, 2)), 0)
 という文字が赤色にかわりました。
 どうしたらよいのでしょうか？　カルロ

 見逃していました（汗

 文字型の数字で試しましたが、きちんと正解がでましたよ？

 試されたデータをアップしていただけませんか？

 (ROUGE)

 文字型、数値型の部分に関してではありませんが、変換の修正場所に関しては
 そりゃ駄目ですよ。左辺値は変換しちゃいけません。
 直すところが違います^^;;。
 ans = WorksheetFunction.Index(Range("B" & i).Resize(, 4), Range("F" & i).Value)
を
 ans = WorksheetFunction.Index(Range("B" & i).Resize(, 4), CInt(Range("F" & i).Value))
 でどうですか。

 でも、ROUGEさんの言うように VB(VBA) は型の自動変換をしてくれるので、たいていは
 あまり気にしなくてもいいはずですけれど、昔のバージョンでは型に関する問題を
 見かけた気がします。 EXCEL のバージョンは何をお使いですか。
 (Mook)

 Mookさん回答有難うございます。エクセルのパージョンは、Excel2002です。
 ans = WorksheetFunction.Index(Range("B" & i).Resize(, 4), CInt(Range("F" & i).Value))
 で試してみましたが、だめでした。
 マクロをステップ実行したら、 
 Range("B" & i).Resize(, UBound(x, 2)).Value = x
 この記述にきた時、文字型数字（'１２、'２５、'１０）が普通の数字(12,25,10)に変換されていました
 カルロ

 アルゴリズムを少し変更。
 でも、String型がDouble?型になる原因は未だ不明ですが。
 (ROUGE)
'----
Sub Carlo()
Dim i As Long, x, ans As Integer
On Error Resume Next
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    x = Range("B" & i).Resize(, 4).SpecialCells(xlCellTypeConstants, 23).Value
    If Err.Number <> 0 Then
        Err.Clear
    Else
        ans = Range("F" & i).Value
        Mazemaze x, ans
        Range("B" & i).Resize(, UBound(x, 2)).Value = x
        Range("F" & i).Value = ans
    End If
Next
On Error GoTo 0
End Sub
Private Sub Mazemaze(x, ans As Integer)
Dim tbl, i As Integer
ReDim tbl(1 To UBound(x, 2), 1 To 3)
Randomize
For i = 1 To UBound(tbl, 1)
    tbl(i, 1) = Int(Rnd * 10000)
    tbl(i, 2) = x(1, i)
Next
tbl(ans, 3) = True
UQS tbl, 1, LBound(tbl, 1), UBound(tbl, 1)
For i = 1 To UBound(tbl, 1)
    x(1, i) = tbl(i, 2)
    If tbl(i, 3) Then ans = i
Next
End Sub
Private Sub UQS(ByRef tbl, ky As Integer, ByVal tp As Long, ByVal bt As Long)
    Dim i As Long, j As Long, k As Integer, m As Long, buf
    i = tp: j = bt: m = (tbl(i, ky) + tbl(j, ky)) \ 2
    Do
        Do While tbl(i, ky) < m
            i = i + 1
        Loop
        Do While tbl(j, ky) > m
            j = j - 1
        Loop
        If i >= j Then Exit Do
        For k = LBound(tbl, 2) To UBound(tbl, 2)
            buf = tbl(i, k): tbl(i, k) = tbl(j, k): tbl(j, k) = buf
        Next
        i = i + 1: j = j - 1
    Loop
    If tp < i - 1 Then UQS tbl, ky, tp, i - 1
    If bt > j + 1 Then UQS tbl, ky, j + 1, bt
End Sub

 ROUGEさん回答有難うございました。
 すごい。文字列の数字を並べ替え成功です。
 上記マクロは、私には難しすぎてよくわかりませんが、
 勉強になりました。有難うございます。
 今後とも　よろしくお願いします（カルロ）

コメント返信：

[ 一覧(最新更新順) ]

[[20080919131054]] 『ランダムで並び替える方法』（カルロ） ページの最後に飛ぶ

[[20080919131054]]　『ランダムで並び替える方法』（カルロ）　ページの最後に飛ぶ