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

' =========================================================================
' メイン1：全問スペル記述テスト（日本語 ➔ 英語 100問）【おすすめ！】
' =========================================================================
Sub CreateTest_AllJapaneseToEnglish_FromList()
    CreateTestCore 3 ' モード3: 全問(訳→英)
End Sub

' =========================================================================
' メイン2：7割/3割 混合テスト（70問:訳→英 / 30問:英→訳）
' =========================================================================
Sub CreateTest_7to3_FromList()
    CreateTestCore 1 ' モード1: 7割(訳→英) / 3割(英→訳)
End Sub

' =========================================================================
' メイン3：全問和訳テスト（英語 ➔ 日本語 100問）
' =========================================================================
Sub CreateTest_AllEnglish_FromList()
    CreateTestCore 2 ' モード2: 全問(英→訳)
End Sub


' -------------------------------------------------------------------------
' 共通コア処理
' -------------------------------------------------------------------------
Private Sub CreateTestCore(testMode As Long)
    Dim startNo As Long, endNo As Long
    Dim inputStr As String
    Dim modeTitle As String
    
    Select Case testMode
        Case 1
            modeTitle = "7割:訳→英 / 3割:英→訳"
        Case 2
            modeTitle = "全問:英→訳(和訳)"
        Case 3
            modeTitle = "全問:訳→英(スペル記述)"
    End Select
    
    ' ユーザー入力
    inputStr = InputBox("出題範囲の単語番号を入力してください。" & vbCrLf & _
                        "（モード: " & modeTitle & "）", "出題範囲指定", "1-500")
    If inputStr = "" Then Exit Sub
    
    Dim parts() As String
    parts = Split(inputStr, "-")
    If UBound(parts) <> 1 Or Not IsNumeric(parts(0)) Or Not IsNumeric(parts(1)) Then
        MsgBox "範囲は「1-500」のように入力してください。", vbExclamation
        Exit Sub
    End If
    
    startNo = CLng(Trim(parts(0)))
    endNo = CLng(Trim(parts(1)))
    
    If startNo <= 0 Or endNo <= 0 Or startNo > endNo Then
        MsgBox "範囲の数値が正しくありません。", vbExclamation
        Exit Sub
    End If
    
    ' 高速化
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 1. 「単語一覧」シートからデータを取得
    Dim allWords As Collection
    Set allWords = CollectWordsFromListSheet(startNo, endNo)
    
    If allWords.Count < 100 Then
        MsgBox "指定範囲内の単語が100問未満です（該当: " & allWords.Count & "問）。" & vbCrLf & _
               "範囲を広げるか、入力した番号をご確認ください。", vbExclamation
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Exit Sub
    End If
    
    ' 2. 重み付けで100問ピックアップ
    Dim selectedWords As Collection
    Set selectedWords = Pick100WordsWeighted(allWords)
    
    ' 3. 出題タイプの決定
    ' 1: 日本語➔英語(スペル書かせる) / 2: 英語➔日本語(和訳)
    Dim qTypes() As Long
    Dim k As Long
    
    If testMode = 1 Then
        qTypes = GetShuffledQuestionTypes(70, 30) ' 70問:訳→英, 30問:英→訳
    ElseIf testMode = 2 Then
        ReDim qTypes(1 To 100)
        For k = 1 To 100: qTypes(k) = 2: Next k ' 全問:英→訳
    ElseIf testMode = 3 Then
        ReDim qTypes(1 To 100)
        For k = 1 To 100: qTypes(k) = 1: Next k ' 全問:訳→英
    End If
    
    ' 4. シート準備
    Dim wsOut As Worksheet, wsAns As Worksheet
    Set wsOut = GetOrCreateSheet("テスト出力")
    Set wsAns = GetOrCreateSheet("解答シート")
    wsOut.Cells.Clear
    wsAns.Cells.Clear
    
    SetupTestSheetLayout wsOut, inputStr, "英単語テスト (" & modeTitle & ")"
    SetupTestSheetLayout wsAns, inputStr, "英単語テスト【解答】"
    
    ' 5. データの流し込み
    Dim i As Long, targetRow As Long
    Dim wordItem As Variant, numVal As Long, engWord As String, jpnWord As String
    Dim qText As String, aText As String
    
    For i = 1 To 100
        wordItem = selectedWords(i)
        numVal = wordItem(0)
        engWord = wordItem(1)
        jpnWord = 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
    Next i
    
    wsOut.Activate
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "100問のテストを作成しました！ (" & modeTitle & ")", vbInformation
End Sub


' --- サブルーチン: 「単語一覧」シートからデータを取得 ---
Private Function CollectWordsFromListSheet(startNo As Long, endNo As Long) As Collection
    Dim col As New Collection
    Dim ws As Worksheet
    Dim lastRow As Long, r As Long
    Dim numVal As Long, cellVal As Variant
    Dim engWord As String, jpnWord As String
    Dim weight As Long
    
    On Error Resume Next
    Set ws = Worksheets("単語一覧")
    On Error GoTo 0
    
    If ws Is Nothing Then
        MsgBox "「単語一覧」という名前のシートが見つかりません。" & vbCrLf & _
               "シート名を確認してください。", vbCritical
        End
    End If
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    For r = 2 To lastRow ' 1行目は見出し
        cellVal = ws.Cells(r, 1).Value
        If IsNumeric(cellVal) And Not IsEmpty(cellVal) Then
            numVal = CLng(cellVal)
            If numVal >= startNo And numVal <= endNo Then
                engWord = Trim(CStr(ws.Cells(r, 2).Value)) ' B列:英単語
                jpnWord = Trim(CStr(ws.Cells(r, 3).Value)) ' C列:訳
                
                If engWord <> "" Then
                    ' 重み計算 (D列を見る)
                    weight = 1
                    If Trim(CStr(ws.Cells(r, 4).Value)) <> "" Then
                        If IsNumeric(ws.Cells(r, 4).Value) Then
                            weight = weight + CLng(ws.Cells(r, 4).Value) ' 数字が入っている場合
                        Else
                            weight = weight + 1 ' 文字・チェックが入っている場合
                        End If
                    End If
                    
                    On Error Resume Next
                    col.Add Array(numVal, engWord, jpnWord, weight), CStr(numVal)
                    On Error GoTo 0
                End If
            End If
        End If
    Next r
    
    Set CollectWordsFromListSheet = col
End Function


' --- サブルーチン: 重み付き抽選 ---
Private Function Pick100WordsWeighted(allWords As Collection) As Collection
    Dim result As New Collection
    Dim availableWords As New Collection
    Dim item As Variant, totalWeight As Long, randVal As Long, currentSum As Long, i As Long
    
    For Each item In allWords: availableWords.Add item: Next item
    
    Randomize
    Do While result.Count < 100 And availableWords.Count > 0
        totalWeight = 0
        For Each item In availableWords: totalWeight = totalWeight + CLng(item(3)): Next item
        
        randVal = Int(Rnd * totalWeight) + 1
        currentSum = 0
        For i = 1 To availableWords.Count
            item = availableWords(i)
            currentSum = currentSum + CLng(item(3))
            If randVal <= currentSum Then
                result.Add item
                availableWords.Remove i
                Exit For
            End If
        Next i
    Loop
    
    Set Pick100WordsWeighted = result
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 Function GetOrCreateSheet(sheetName As String) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sheetName)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = sheetName
    End If
    Set GetOrCreateSheet = 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