【中学英語】実力テストの英単語対策！AIでランダム単語テストを作ってみた

Option Explicit

' ============================================================
' ボタン登録用プロシージャ（Excelのボタンに割り当てる用）
' ============================================================
Sub テスト作成_7割3割()
    CreateTest 1
End Sub

Sub テスト作成_全問英訳()
    CreateTest 2
End Sub

Sub テスト作成_全問和訳()
    CreateTest 3
End Sub


' ============================================================
' メイン処理（テスト作成）
' ============================================================
Sub CreateTest(testMode As Long)
    Dim wsList As Worksheet
    Dim wsHist As Worksheet
    Dim wsOut As Worksheet
    Dim wsAns As Worksheet

    Dim inputStr As String
    Dim modeTitle As String

    ' --------------------------------------------------------
    ' シート取得・自動作成
    ' --------------------------------------------------------
    On Error Resume Next
    Set wsList = ThisWorkbook.Worksheets("単語一覧")
    Set wsHist = ThisWorkbook.Worksheets("出題履歴")
    Set wsOut = ThisWorkbook.Worksheets("テスト出力")
    Set wsAns = ThisWorkbook.Worksheets("解答シート")
    On Error GoTo 0

    If wsList Is Nothing Then
        MsgBox "「単語一覧」シートが見つかりません。" & vbCrLf & _
               "シート名を確認してください。", vbCritical
        Exit Sub
    End If

    If wsHist Is Nothing Then
        Set wsHist = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsHist.Name = "出題履歴"
    End If

    If wsOut Is Nothing Then
        Set wsOut = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsOut.Name = "テスト出力"
    End If

    If wsAns Is Nothing Then
        Set wsAns = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsAns.Name = "解答シート"
    End If

    ' --------------------------------------------------------
    ' モード設定
    ' --------------------------------------------------------
    Select Case testMode
        Case 1: modeTitle = "7割：訳→英 / 3割：英→訳"
        Case 2: modeTitle = "全問：英→訳"
        Case 3: modeTitle = "全問：訳→英"
        Case Else
            MsgBox "テストモードが正しくありません。", vbCritical
            Exit Sub
    End Select

    ' --------------------------------------------------------
    ' 範囲指定インプットボックス
    ' --------------------------------------------------------
    inputStr = InputBox( _
        "出題範囲を入力してください。" & vbCrLf & vbCrLf & _
        "例：" & vbCrLf & _
        "1-500" & vbCrLf & _
        "1150-1200,1-500" & vbCrLf & _
        "1-100,300-400,800-900" & vbCrLf & vbCrLf & _
        "モード：" & modeTitle, _
        "出題範囲指定", _
        "1-1200")

    If Trim(inputStr) = "" Then Exit Sub

    ' 履歴の同期
    InitializeHistory wsList, wsHist

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' 単語抽出
    Dim allWords As Collection
    Set allWords = CollectWordsFromListSheet(wsList, inputStr)

    If allWords.Count < 100 Then
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        MsgBox "指定範囲内の単語が100問未満です。" & vbCrLf & _
               "該当：" & allWords.Count & "問" & vbCrLf & vbCrLf & _
               "100問以上になるように範囲を広げてください。", vbExclamation
        Exit Sub
    End If

    ' 重み付き抽選で100問選出
    Dim selectedWords As Collection
    Set selectedWords = Pick100WordsWeighted(allWords, wsHist)

    ' 問題形式の決定
    Dim qTypes() As Long
    Dim i As Long

    If testMode = 1 Then
        qTypes = GetShuffledQuestionTypes(70, 30)
    Else
        ReDim qTypes(1 To 100)
        For i = 1 To 100
            qTypes(i) = IIf(testMode = 3, 1, 2)
        Next i
    End If

    ' シートの初期化とレイアウト
    wsOut.Cells.Clear
    wsAns.Cells.Clear

    SetupTestSheetLayout wsOut, inputStr, "英単語テスト (" & modeTitle & ")"
    SetupTestSheetLayout wsAns, inputStr, "英単語テスト【解答】"

    ' --------------------------------------------------------
    ' 問題書き込み
    ' --------------------------------------------------------
    Dim wordItem As Variant
    Dim numVal As Long, engWord As String, jpnWord As String
    Dim qText As String, aText As String, targetRow As Long

    For i = 1 To 100
        wordItem = selectedWords(i)
        numVal = CLng(wordItem(0))
        engWord = CStr(wordItem(1))
        jpnWord = CStr(wordItem(2))

        If qTypes(i) = 1 Then
            qText = jpnWord
            aText = engWord
        Else
            qText = engWord
            aText = jpnWord
        End If

        If i <= 50 Then
            targetRow = i + 4
            wsOut.Cells(targetRow, 1).Value = numVal
            wsOut.Cells(targetRow, 2).Value = qText
            wsAns.Cells(targetRow, 1).Value = numVal
            wsAns.Cells(targetRow, 2).Value = qText
            wsAns.Cells(targetRow, 3).Value = aText
            wsAns.Cells(targetRow, 3).Font.Color = RGB(200, 0, 0)
        Else
            targetRow = (i - 50) + 4
            wsOut.Cells(targetRow, 5).Value = numVal
            wsOut.Cells(targetRow, 6).Value = qText
            wsAns.Cells(targetRow, 5).Value = numVal
            wsAns.Cells(targetRow, 6).Value = qText
            wsAns.Cells(targetRow, 7).Value = aText
            wsAns.Cells(targetRow, 7).Font.Color = RGB(200, 0, 0)
        End If

        ' 出題回数を+1
        IncrementQuestionCount wsHist, numVal
    Next i

    wsOut.Activate
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MsgBox "100問のテストを作成しました！" & vbCrLf & vbCrLf & _
           "モード：" & modeTitle & vbCrLf & _
           "出題範囲：" & inputStr & vbCrLf & vbCrLf & _
           "「テスト出力」＝問題" & vbCrLf & _
           "「解答シート」＝答え", vbInformation, "テスト作成完了"
End Sub


' ============================================================
' 不正解一括記録マクロ（丸付け後に実行する用）
' ============================================================
Sub 不正解記録()
    Dim wsHist As Worksheet
    Set wsHist = GetOrCreateHistorySheet()

    Dim s As String
    s = InputBox("間違えた問題番号を入力してください。" & vbCrLf & vbCrLf & _
                 "複数ある場合はカンマで区切ってください。" & vbCrLf & _
                 "例：12,45,78,103", "不正解記録")
    If Trim(s) = "" Then Exit Sub

    Dim nums() As String: nums = Split(s, ",")
    Dim i As Long, numVal As Long, hRow As Long
    Dim successCount As Long, errorCount As Long, oneNum As String

    For i = LBound(nums) To UBound(nums)
        oneNum = Trim(nums(i))
        If oneNum <> "" And IsNumeric(oneNum) Then
            numVal = CLng(oneNum)
            hRow = FindHistoryRow(wsHist, numVal)
            If hRow > 0 Then
                If IsNumeric(wsHist.Cells(hRow, 4).Value) Then
                    wsHist.Cells(hRow, 4).Value = CLng(wsHist.Cells(hRow, 4).Value) + 1
                Else
                    wsHist.Cells(hRow, 4).Value = 1
                End If
                successCount = successCount + 1
            Else
                errorCount = errorCount + 1
            End If
        Else
            If oneNum <> "" Then errorCount = errorCount + 1
        End If
    Next i

    Dim msg As String
    msg = successCount & "問の不正解を記録しました。"
    If errorCount > 0 Then msg = msg & vbCrLf & "確認できなかった番号：" & errorCount & "件"
    MsgBox msg, vbInformation, "不正解記録完了"
End Sub


' ============================================================
' 内部処理・関数群
' ============================================================
Private Sub InitializeHistory(wsList As Worksheet, wsHist As Worksheet)
    Dim lastRow As Long, r As Long, numVal As Long, engWord As String
    Dim hRow As Long, nextRow As Long

    wsHist.Cells(1, 1).Value = "番号"
    wsHist.Cells(1, 2).Value = "単語"
    wsHist.Cells(1, 3).Value = "出題回数"
    wsHist.Cells(1, 4).Value = "不正解回数"
    wsHist.Range("A1:D1").Font.Bold = True

    lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row

    For r = 2 To lastRow
        If IsNumeric(wsList.Cells(r, 1).Value) Then
            numVal = CLng(wsList.Cells(r, 1).Value)
            engWord = Trim(CStr(wsList.Cells(r, 2).Value))
            If engWord <> "" Then
                hRow = FindHistoryRow(wsHist, numVal)
                If hRow = 0 Then
                    nextRow = wsHist.Cells(wsHist.Rows.Count, 1).End(xlUp).Row + 1
                    If nextRow < 2 Then nextRow = 2
                    wsHist.Cells(nextRow, 1).Value = numVal
                    wsHist.Cells(nextRow, 2).Value = engWord
                    wsHist.Cells(nextRow, 3).Value = 0
                    wsHist.Cells(nextRow, 4).Value = 0
                Else
                    wsHist.Cells(hRow, 2).Value = engWord
                End If
            End If
        End If
    Next r
    wsHist.Columns("A:D").AutoFit
End Sub

Private Function FindHistoryRow(wsHist As Worksheet, numVal As Long) As Long
    Dim lastRow As Long, r As Long
    lastRow = wsHist.Cells(wsHist.Rows.Count, 1).End(xlUp).Row
    For r = 2 To lastRow
        If IsNumeric(wsHist.Cells(r, 1).Value) Then
            If CLng(wsHist.Cells(r, 1).Value) = numVal Then
                FindHistoryRow = r
                Exit Function
            End If
        End If
    Next r
    FindHistoryRow = 0
End Function

Private Function FindHistoryRowByNumber(wsHist As Worksheet, numVal As Long) As Long
    FindHistoryRowByNumber = FindHistoryRow(wsHist, numVal)
End Function

Private Function CollectWordsFromListSheet(ws As Worksheet, rangeText As String) As Collection
    Dim col As New Collection
    Dim lastRow As Long, r As Long, cellVal As Variant, numVal As Long
    Dim engWord As String, jpnWord As String, weight As Double, hRow As Long
    Dim rangesText() As String, addedNumbers As Object

    Set addedNumbers = CreateObject("Scripting.Dictionary")
    rangesText = Split(rangeText, ",")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    For r = 2 To lastRow
        cellVal = ws.Cells(r, 1).Value
        If IsNumeric(cellVal) Then
            numVal = CLng(cellVal)
            If IsNumberInMultipleRanges(numVal, rangesText) Then
                If Not addedNumbers.Exists(CStr(numVal)) Then
                    engWord = Trim(CStr(ws.Cells(r, 2).Value))
                    jpnWord = Trim(CStr(ws.Cells(r, 3).Value))
                    If engWord <> "" Then
                        hRow = FindHistoryRowByNumber(ThisWorkbook.Worksheets("出題履歴"), numVal)
                        If hRow > 0 Then
                            If IsNumeric(ThisWorkbook.Worksheets("出題履歴").Cells(hRow, 4).Value) Then
                                weight = CDbl(ThisWorkbook.Worksheets("出題履歴").Cells(hRow, 4).Value) + 1
                            Else
                                weight = 1
                            End If
                        Else
                            weight = 1
                        End If
                        col.Add Array(numVal, engWord, jpnWord, weight)
                        addedNumbers.Add CStr(numVal), True
                    End If
                End If
            End If
        End If
    Next r
    Set CollectWordsFromListSheet = col
End Function

Private Function IsNumberInMultipleRanges(numVal As Long, rangesText() As String) As Boolean
    Dim i As Long, oneRange As String, parts() As String, startNo As Long, endNo As Long
    For i = LBound(rangesText) To UBound(rangesText)
        oneRange = Trim(rangesText(i))
        If oneRange <> "" Then
            parts = Split(oneRange, "-")
            If UBound(parts) = 1 Then
                If IsNumeric(Trim(parts(0))) And IsNumeric(Trim(parts(1))) Then
                    startNo = CLng(Trim(parts(0)))
                    endNo = CLng(Trim(parts(1)))
                    If startNo > endNo Then
                        Dim tmp As Long: tmp = startNo: startNo = endNo: endNo = tmp
                    End If
                    If numVal >= startNo And numVal <= endNo Then
                        IsNumberInMultipleRanges = True
                        Exit Function
                    End If
                End If
            End If
        End If
    Next i
    IsNumberInMultipleRanges = False
End Function

Private Function Pick100WordsWeighted(allWords As Collection, wsHist As Worksheet) As Collection
    Dim selectedCol As New Collection
    Dim tempWords As New Collection
    Dim item As Variant, i As Long, totalWeight As Double, rndVal As Double, currentWeight As Double
    Dim pickedIndex As Long

    For i = 1 To allWords.Count
        tempWords.Add allWords(i)
    Next i

    Randomize
    Do While selectedCol.Count < 100 And tempWords.Count > 0
        totalWeight = 0
        For i = 1 To tempWords.Count
            item = tempWords(i)
            totalWeight = totalWeight + CDbl(item(3))
        Next i

        rndVal = Rnd() * totalWeight
        currentWeight = 0
        pickedIndex = 1

        For i = 1 To tempWords.Count
            item = tempWords(i)
            currentWeight = currentWeight + CDbl(item(3))
            If currentWeight >= rndVal Then
                pickedIndex = i
                Exit For
            End If
        Next i

        selectedCol.Add tempWords(pickedIndex)
        tempWords.Remove pickedIndex
    Loop

    Set Pick100WordsWeighted = selectedCol
End Function

Private Function GetShuffledQuestionTypes(countType1 As Long, countType2 As Long) As Long()
    Dim total As Long: total = countType1 + countType2
    Dim arr() As Long: ReDim arr(1 To total)
    Dim i As Long, j As Long, tmp As Long

    For i = 1 To countType1: arr(i) = 1: Next i
    For i = countType1 + 1 To total: arr(i) = 2: Next i

    Randomize
    For i = total To 2 Step -1
        j = Int(Rnd() * i) + 1
        tmp = arr(i): arr(i) = arr(j): arr(j) = tmp
    Next i
    GetShuffledQuestionTypes = arr
End Function

Private Sub IncrementQuestionCount(wsHist As Worksheet, numVal As Long)
    Dim hRow As Long
    hRow = FindHistoryRow(wsHist, numVal)
    If hRow > 0 Then
        If IsNumeric(wsHist.Cells(hRow, 3).Value) Then
            wsHist.Cells(hRow, 3).Value = CLng(wsHist.Cells(hRow, 3).Value) + 1
        Else
            wsHist.Cells(hRow, 3).Value = 1
        End If
    End If
End Sub

Private Function GetOrCreateHistorySheet() As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets("出題履歴")
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        ws.Name = "出題履歴"
        ws.Cells(1, 1).Value = "番号"
        ws.Cells(1, 2).Value = "単語"
        ws.Cells(1, 3).Value = "出題回数"
        ws.Cells(1, 4).Value = "不正解回数"
        ws.Range("A1:D1").Font.Bold = True
    End If
    Set GetOrCreateHistorySheet = ws
End Function

Private Sub SetupTestSheetLayout(ws As Worksheet, rangeStr As String, titleName As String)
    ws.Cells(1, 1).Value = titleName & " (出題範囲: " & rangeStr & ")"
    ws.Cells(1, 1).Font.Size = 14
    ws.Cells(1, 1).Font.Bold = True

    ws.Cells(2, 1).Value = "目標時間［10分/100問］"
    ws.Cells(2, 6).Value = "解答時間（　）分"
    ws.Cells(2, 7).Value = "得点:      / 100"

    ws.Cells(4, 1).Value = "番号"
    ws.Cells(4, 2).Value = "問題"
    ws.Cells(4, 3).Value = "解答"
    ws.Cells(4, 5).Value = "番号"
    ws.Cells(4, 6).Value = "問題"
    ws.Cells(4, 7).Value = "解答"

    Dim rngList As Variant
    rngList = Array(ws.Range("A4:C54"), ws.Range("E4:G54"))
    Dim k As Long
    For k = LBound(rngList) To UBound(rngList)
        With rngList(k).Borders
            .LineStyle = xlContinuous
            .weight = xlThin
        End With
        rngList(k).Rows(1).Interior.Color = RGB(220, 230, 242)
        rngList(k).Rows(1).Font.Bold = True
    Next k

    ws.Columns("A").ColumnWidth = 8
    ws.Columns("B").ColumnWidth = 22
    ws.Columns("C").ColumnWidth = 20
    ws.Columns("D").ColumnWidth = 3
    ws.Columns("E").ColumnWidth = 8
    ws.Columns("F").ColumnWidth = 22
    ws.Columns("G").ColumnWidth = 20
End Sub