【Excel VBA】四択クイズのプログラムで重複した問題を出題させないようにしたい

Question

前提

以下のサイトに記載のVBAコードで、四択問題を出し、正誤の結果を記録するプログラムを作成します。

試験勉強に最適な「Excel 4択クイズ実行プログラム」

プログラムの概要は以下の通りです。

1. Sheet1に問題と選択肢、解説を入力する。（A列：問題番号、B列：問題文、C列：選択肢（正答）、D~F列：選択肢（誤答）、G列：解説文
2. Sheet2のボタンを押してプログラムを実行するとフォームが表示される。
3. 「スタート」をクリックする。
4. 入力した問題がランダムに実行される。選択肢の位置もランダム表示される。
5. 4つの選択肢ボタンを押して答えを選ぶ。
6. 正答か誤答かフィードバックされる。（入力していれば、解説も表示される）
7. 次の問題に進むかどうか聞かれる。
8. 「はい」→④に戻り、くり返す。「いいえ」→出題を終了する。
9. 日付、正答率、問題番号と正誤を記録する。Sheet3の「データ処理」ボタンを押すと問題番号順に正誤の結果が並び替えられる。重複データは削除され、正答と誤答どちらを優先するかも変更できる。

作成したフォームは下の画像の通りです。

オレンジは、各要素のオブジェクト名や大きさ等を示しています。このオブジェクトを元にコードを入力します。

実現したいこと

掲載されたコードの通りに作成してプログラムは問題なく実行できましたが、実際に使ってみると、同じ問題が何度も出題される上、⑧で「いいえ」を選択しないとプログラムを終了できない、と不便さを感じました。
そこで今度は⑧と⑨の手順の間に次の手順を追加したいです。

1. 次の問題に進む時に既出の問題を重複して出題しないようにする
2. 全ての問題が出題されたら、出題を強制終了する

該当のソースコード

フォーム内に記載したコードは以下の通りです。「フォームの実行」と「データ処理」のコードはここでは省略します。

Option Explicit
Dim CorrectAns, CmntRow

Private Sub UserForm_Initialize()
   info.Visible = False
End Sub

Private Sub ToggleButton5_Click()
    setQuizData
    
'保存用シートへのデータ貼りつけ用の最終列取得の次の列i
    Dim i
    i = Sheet3.Cells(1, Columns.Count).End(xlToLeft).Column
    If Sheet3.Cells(1, i).Value <> "" Then i = i + 1 'A1が空白ならiを1とする
    
'記録用シートに日付を入力する
Sheet2.Range("A1").Value = Date
Sheet2.Range("B1").Value = "％" '後に正答率を入力する
    
Do
    While info.Visible = False
        DoEvents
    Wend
    
    Dim nextQuiz
    nextQuiz = MsgBox("次の問題に進みますか？", vbInformation + vbYesNo)
    If nextQuiz = vbYes Then
        info.Visible = False
        setQuizData
    Else
        Exit Do
    End If
        
    Loop
    Sheet2.Range("A1").CurrentRegion.Copy 'Sheet2のデータをコピー
    'Sheet3に貼りつけ
    Sheet3.Cells(1, i).PasteSpecial Paste:=xlPasteValues, _
    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheet3.Cells(1, i).NumberFormatLocal = "mm/dd" '表示形式を00月00日へ
    Sheet3.Cells(1, i + 1).NumberFormatLocal = "0%" '表示形式をパーセントへ
    Sheet2.Cells.Clear '記録用シートの初期化

    Call getAverage(i)
    
    MsgBox "問題集を終了します", vbInformation + vbOKOnly
    Unload Me
End Sub

Private Sub getAverage(ByVal lBeginCol As Long)

    Const TARGET_SHEET_NAME As String = "Sheet3"
    Const COL_OFFSET        As Long = 2
    Dim sHeader     As String
    Dim lCol        As Long
    Dim lEndRow     As Long
    Dim lTargetCol  As Long

    lCol = lBeginCol

    With ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
        sHeader = .Cells(1, lCol).Value

        Do Until sHeader = ""
            lEndRow = .Cells(1, lCol).End(xlDown).Row

            lTargetCol = lCol + 1

            .Cells(1, lTargetCol).Value = WorksheetFunction.Average(.Range(.Cells(2, lTargetCol), .Cells(lEndRow, lTargetCol)))

            lCol = lCol + COL_OFFSET

            sHeader = .Cells(1, lCol).Value
        Loop
    End With
End Sub

Private Sub setQuizData()
    
    Randomize '乱数ジェネレータを初期化    
    Dim rowNo
    rowNo = Int(Rnd * Sheet1.UsedRange.Rows.Count + 1)
    quizText.Text = Sheet1.Cells(rowNo, 2)
    CmntText.Text = ""
    
'rowNoは問題の行数    
'解説を表示するためにrowNoを記録しておく
    CmntRow = rowNo
        
'問題ナンバーを入力する行番号mを定義
Dim m
    m = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row + 1    
    ans1.Value = False
    ans2.Value = False
    ans3.Value = False
    ans4.Value = False
    
    ans1.Caption = ""
    ans2.Caption = ""
    ans3.Caption = ""
   ans4.Caption = ""
    
'変数の説明
'ansFlag: いくつ選択肢を設定したのかを記憶しておく箱
'ansNo: 1から4の間で発生させた乱数の値を記憶しておく箱
'colNo: Sheet1の3列目から6列目に格納されている選択肢の、何番目までを設定したのかを記憶しておく箱
    
    Dim ansFlag, ansNo, colNo
    ansFlag = 0
    ansNo = 0
    colNo = 3
    While ansFlag < 4 'ansFlagが4より小さいあいだ処理をくり返す
        ansNo = Int(Rnd * 4 + 1) '0～1までの乱数Rnd に4をかけ、1を足し、小数点以下を切り捨てるInt
        If UserForm1.Controls("ans" & ansNo).Caption = "" Then
            UserForm1.Controls("ans" & ansNo).Caption = Sheet1.Cells(rowNo, colNo)
            ansFlag = ansFlag + 1
            
        Sheet2.Range("A" & m).Value = Sheet1.Cells(rowNo, 1) '記録シートに問題番号を入力
                    
            '正答(Sheet1の3列目)がどのトグルボタンに設定されたかをCorrectAnsに記憶
            If colNo = 3 Then
                CorrectAns = ansNo
            End If
            colNo = colNo + 1
        End If
    Wend

End Sub

Private Sub answerJudg(tName)
Dim n
    n = Sheet2.Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    If UserForm1.Controls("ans" & tName).Value = False Then
        Exit Sub
    End If
    
    If CorrectAns = tName Then
        info.Caption = "○ 正解"
        CmntText = Sheet1.Cells(CmntRow, 7)
        Sheet2.Range("B" & n).Value = "1" '記録用シートに正答を記録する
    Else
        info.Caption = "× 不正解"
        CmntText = Sheet1.Cells(CmntRow, 7)
        Sheet2.Range("B" & n).Value = "0" '記録用シートに誤答を記録する
        
    End If
    info.Visible = True
End Sub

Private Sub ans1_Click()
    answerJudg (1)
End Sub

Private Sub ans2_Click()
    answerJudg (2)
End Sub
    
Private Sub ans3_Click()
    answerJudg (3)
End Sub

Private Sub ans4_Click()
    answerJudg (4)
End Sub

試したこと

重複してしまう原因はsetQuizData()内のRandomizeでルーチンを初期化しているのが原因かと思います。
次の問題に進む時、問題の参照にiを使わず、rowNoにセットする値を工夫する事で、未出題か出題済みか判定するような処理を書けば、問題の重複を避けられるかな、と考えています。
ただ参考になるサイトが見つからず具体的にどんなコードを書けばいいかわからない状況です。
回答となるコードを丸ごといただければ勿論うれしいですが、それだけでは今後の勉強にならないので、考え方やヒントをいただければ幸いです。
よろしくお願いいたします。

追記

いただいた回答を元にコードをいくつか修正しました。途中までの重複しない出題は達成できましたが、全問を出題した後の処理が進まない状態です。

Private Sub ToggleButton5_Click()
    Dim end_flag As Boolean
    Call setQuizData(end_flag)
    
'保存用シートへのデータ貼りつけ用の最終列取得の次の列i
    Dim i
    i = Sheet3.Cells(1, Columns.Count).End(xlToLeft).Column
    If Sheet3.Cells(1, i).Value <> "" Then i = i + 1 'A1が空白ならiを1とする
    
'記録用シートに日付を入力する
Sheet2.Range("A1").Value = Date
Sheet2.Range("B1").Value = "％" '後に正答率を入力する    
    
Do
    While Info.Visible = False
        DoEvents
    Wend
    
    Dim nextQuiz
    nextQuiz = MsgBox("次の問題に進みますか？", vbInformation + vbYesNo)
    If nextQuiz = vbYes Then
        Info.Visible = False
        Call setQuizData(end_flag)
        
    ElseIf end_flag = True Then
       Exit Do
    
    Else
       Exit Do
    End If
        
    Loop
    Sheet2.Range("A1").CurrentRegion.Copy 'Sheet2のデータをコピー
    'Sheet3に貼りつけ
    Sheet3.Cells(1, i).PasteSpecial Paste:=xlPasteValues, _
    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheet3.Cells(1, i).NumberFormatLocal = "mm/dd" '表示形式を00月00日へ
    Sheet3.Cells(1, i + 1).NumberFormatLocal = "0%" '表示形式をパーセントへ
    Sheet2.Cells.Clear '記録用シートの初期化

    Call getAverage(i)
    
    MsgBox "問題集を終了します", vbInformation + vbOKOnly
    Unload Me

End Sub

Private Sub setQuizData(ByRef end_flag As Boolean)
    end_flag = True
    
    '空いている行をrowNoに設定する。空き行がない場合は、-1をrowNoに設定する。
    Dim rowNo As Long
    Call get_row_number(rowNo)
    
    'すべて
    If rowNo = -1 Then
    Exit Sub
    End If
    
    quizText.Text = Sheet1.Cells(rowNo, 2)
    CmntText.Text = ""

    'rowNoは問題の行数
    '解説を表示するためにrowNoを記録しておく
    CmntRow = rowNo
    
    
    '問題ナンバーを入力する行番号mを定義
    Dim m
    m = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    ans1.Value = False
    ans2.Value = False
    ans3.Value = False
    ans4.Value = False
    

    ans1.Caption = ""
    ans2.Caption = ""
    ans3.Caption = ""
    ans4.Caption = ""
    
'変数の説明
'ansFlag: いくつ選択肢を設定したのかを記憶しておく箱
'ansNo: 1から4の間で発生させた乱数の値を記憶しておく箱
'colNo: Sheet1の3列目から6列目に格納されている選択肢の、何番目までを設定したのかを記憶しておく箱
    
    Dim ansFlag, ansNo, colNo
    ansFlag = 0
    ansNo = 0
    colNo = 3
    While ansFlag < 4 'ansFlagが4より小さいあいだ処理をくり返す
        ansNo = Int(Rnd * 4 + 1) '0～1までの乱数Rnd に4をかけ、1を足し、小数点以下を切り捨てるInt
        If UserForm1.Controls("ans" & ansNo).Caption = "" Then
            UserForm1.Controls("ans" & ansNo).Caption = Sheet1.Cells(rowNo, colNo)
            ansFlag = ansFlag + 1
            
        Sheet2.Range("A" & m).Value = Sheet1.Cells(rowNo, 1) '記録シートに問題番号を入力
                    
            '正答(Sheet1の3列目)がどのトグルボタンに設定されたかをCorrectAnsに記憶
            If colNo = 3 Then
                CorrectAns = ansNo
            End If
            colNo = colNo + 1
        End If
    Wend
    
    end_flag = False
End Sub

Answer 1

ToggleButton5_ClickのDo～Loopですが以下のようにしてください。
Call setQuizData(end_flag)
の次の行に
If end_flag = True Then
info.Visible = True
Exit Do
End If

を入れます。
前の回答ではinfo.Visibleを考慮していませんでした。
exit Doするときは、info.VisibleがTrueになっていないといけないようなので、そのようにしました。

    Do
        While info.Visible = False
            DoEvents
        Wend

        Dim nextQuiz
        nextQuiz = MsgBox("次の問題に進みますか？", vbInformation + vbYesNo)
        If nextQuiz = vbYes Then
            info.Visible = False

            Call setQuizData(end_flag)
            If end_flag = True Then
                info.Visible = True
                Exit Do
            End If
        Else
            Exit Do
        End If

    Loop

Comments

[koburon]

回答ありがとうございます。最終問題を出題後にエラー無く終了できました。理想通りのプログラムが実行できました。本当にありがとうございました。こちらをベストアンサーとさせていただきます。

Answer 2

空き行を返す関数です。

'空き行を返す関数
Private Sub get_row_number(ByRef rowNo As Long)
    Dim wrow As Long
    Dim wrow_save As Long
    wrow = Int(Rnd * Sheet1.UsedRange.Rows.Count + 1)
    '乱数で取得した行番号が空きなら、その行番号を返す
    If Sheet1.Cells(wrow, "Z").Value = "" Then
        Sheet1.Cells(wrow, "Z").Value = 1
        rowNo = wrow
        Exit Sub
    End If
    wrow_save = wrow
    '乱数で取得した行番号の次から下へ最後まで空き行を検索する
    For wrow = wrow_save + 1 To Sheet1.UsedRange.Rows.Count
        '空き行があれば、その行番号を返す
        If Sheet1.Cells(wrow, "Z").Value = "" Then
            Sheet1.Cells(wrow, "Z").Value = 1
            rowNo = wrow
            Exit Sub
        End If
    Next
    '乱数で取得した行番号の前から上へ先頭まで空き行を検索する
    For wrow = wrow_save + -1 To 1 Step -1
        '空き行があれば、その行番号を返す
        If Sheet1.Cells(wrow, "Z").Value = "" Then
            Sheet1.Cells(wrow, "Z").Value = 1
            rowNo = wrow
            Exit Sub
        End If
    Next
    '空き行がないので、-1を返す
    rowNo = -1
End Sub

呼び出し側

Dim rowNo As Long
Call get_row_number(rowNo)
'空いている行がrowNoに設定されます。空き行がない場合は、-1がrowNoに設定されます。

UserForm_Initializeに以下の行を追加します。

   'Z列をクリアする
   Sheet1.Range("Z1:Z" & Sheet1.UsedRange.Rows.Count).ClearContents
   Randomize '乱数ジェネレータを初期化

Comments

[koburon]

回答ありがとうございます。UserForm_Initialize()の中にZ列のクリアを追記、空き行を返す関数のSubを追加しました。呼び出し側のコードはsetQuizData()内の以下の80～81行から差し替える、という認識でよろしいでしょうか。

ーーーーーーーーーーー
Dim rowNo
rowNo = Int(Rnd * Sheet1.UsedRange.Rows.Count + 1)
ーーーーーーーーーーー

試しに差し替えて実行したところ、重複せず出題されるようになりましたが、最後の問題を解答すると、エラーが生じてしまいました。コードの挿入する場所が間違っているのでしょうか。

[tatsu99]

はい。あってます。
７９行のRandomize '乱数ジェネレータを初期化
は、削除してますね。（UserForm_Initializeへ移動）

「最後の問題を解答すると、エラーが生じてしまいました。」ということですが、
call Call get_row_number(rowNo)の結果
割当行がなくなると、最後にはrowNoに-1が設定されます。
このケースについては、触れていませんでしたが、このケースを考慮する必要があります。
つまり、「全ての問題が出題されたら、出題を強制終了する」ことの実現になります。

これに関しては、少々厄介です。
ToggleButton5_Click()の２９行
setQuizDataを呼び出した後に、全部問題が出題された時の判定を追加する必要があります。
そして、setQuizData側では、
①正常に終了、②全部問題が出題された為に終了　のどちらかを返すようにする必要があります。

Private Sub setQuizData()を
Private Sub setQuizData(ByRef end_flag As Boolean)
に変えます。
setQuizDataの最初に
end_flag = True
を追加します。
Dim rowNo As Long
Call get_row_number(rowNo)
の後に
If rowNo = -1 Then Exit Sub
を追加します。
setQuizDataの最後に
end_flag = False
を追加します。

呼び出し側（ToggleButton5_Click）ですが
ToggleButton5_Clickの先頭へ
dim end_flag as Boolean
を追加します。

２９行のsetQuizData
を
Call setQuizData(end_flag)
If end_flag = True Then Exit Do
に変えます。

不明点１
９行目にsetQuizDataがありますが、これは必要なのでしょうか。
もし、必要であれば、
Call setQuizData(end_flag)
にかえてください。

不明点２
Sheet1の１行目と最終行は、出題の対象行にして良いのでしょうか。
それとも、１行目と最終行を除いて、出題するのでしょうか。

[koburon]

回答ありがとうございます。
不明点について回答いたします。
・不明点１
→setQuizDataの文を抜いて実行すると、フォームのスタートボタンを押しても問題が始まりませんでした。コメント通り、Call setQuizData(end_flag)に変えると出題できるようになりました。
・不明点２
→１行目と最終行も対象行です。なので、提示いただいたコードで１行目と最終行も出題するようにします。

コメントいただいたように修正し実行したところ、途中までは重複しないように出題されましたが、最終問題を解答した後に「はい」をクリックすると出題を終了できずそのまま固まってしまいました。
修正途中のそれぞれのコードを質問文に追記したので、ご面倒をおかけしますが確認していただきどこで入力ミスしているかコメントいただけないでしょうか。

Answer 3

とりあえず、手っ取り早い方法は、２回目のrowNoは採用しないようにすることかと思います。
その為には、
１．Sheet1の空いている列（例えばZ列とします）を記憶用に使います。
２．UserForm_Initialize()の中で、Z列を全行分クリアしておきます。
３．乱数でrowNoを求めたとき、Z列のrowNo行が空白なら、その行を使用し、その行へ１をセットします。
４．乱数でrowNoを求めたとき、Z列のrowNo行が空白でないなら、その行は使えません。
その場合、以下の方法が考えられます。
１案．再度乱数を発行し、Z列のrowNo行が空白になるまで、繰り返す。
２案．そのrowNoから下へ空白の行を検索する。空白の行があれば、それをrowNo行として採用する。
最後の行まで検索しても、空白行がないなら、上へ向かって同様に検索する。空白行があれば、それをrowNo行として採用する。
先頭行まで検索しても、空白行がない場合は、全て使用済みということなので、出題を強制終了する。

個人的には２案を推奨します。（ランダム度が弱くなりますが、不要なループを繰り返さずに済みます）

Comments

[koburon]

回答ありがとうございます。今後問題数を増やしていく予定なのでループが少なく済む2案で進めたいと思います。試しに自力で条件分岐を入力し、コード84行目の位置に以下のように追加しました。

ーーーーーーーーーーー
'Z列のrowNo行が空白なら、セルに１をセット
'Z列のrowNo行が空白でないなら1つ下を検索、空白であれば１をセット
'Z列のrowNo行の1つ下が空白でないなら１つ上を検索、空白であれば１をセット
'空白行がなくなったら出題を終了する

If Sheet1.Cells(rowNo, 26) = "" Then
Sheet1.Cells(rowNo, 26) = "1"

ElseIf Sheet1.Cells(rowNo, 26) = "1" Then
rowNo = rowNo + 1

ElseIf Sheet1.Cells(rowNo + 1, 26) = "1" Then
rowNo = rowNo - 1

Else
Exit Sub
MsgBox "問題を終了します", vbInformation + vbOKOnly
Unload Me

End If
ーーーーーーーーーーー

エラーは生じなかったのですが、初期状態と同じく、同じ問題が何度も出題されてしまい、問題の終了も「いいえ」を押す必要があります。また、何問か解いていると問題文と選択肢が表示されないパターンがありました。これは1行目か最終行のオフセットを参照してしまったことが原因だと思いますが、1行目と最終行の場合は参照しないように制限することができるのでしょうか。直す点がどこかアドバイスいただけないでしょうか。

[tatsu99]

'Z列のrowNo行が空白なら、セルに１をセット
'Z列のrowNo行が空白でないなら1つ下を検索、空白であれば１をセット
'Z列のrowNo行の1つ下が空白でないなら１つ上を検索、空白であれば１をセット
'空白行がなくなったら出題を終了する

Z列が空白でないなら、下へ空白でない行を最後まで探します。
それもないなら、上へ先頭まで探します。
探すのが、下へ１行、上へ1行だけのように見えます。

＞1行目と最終行の場合は参照しないように制限することができるのでしょうか。
rowNoが１であれば、１行目なので、スキップする。
rowNoが最後の行なら、スキップする。ということをすれば、良いかと思います。
１行目と最後の行は、問題の対象外の行なのでしょうか？

[tatsu99]

サンプルで空き行を返す関数を回答欄に書きます。
１行目と最終行も対象にしてあります。
１行目と最後の行は、問題の対象外の行であることが、明確になれば、その行はスキップするように後で変更すれば良いでしょう。

Answer 4

考え方で言えば配列に問題(問題がある行番号)を格納して出題された問題(行番号)を配列から削除する
という感じでもできるかと思います。
ですがVBAで配列を扱うのは少し手間かもしれません。
追記
VBAには「Collection」というものがあったので配列じゃなくこちらを使えば簡単かもしれません。