VBA：给三年级小朋友设计一个英语单词默写测试卷

又到了小朋友们期末考试的时间了（快乐的暑假马上就要开始了！！）

说真，儿子还是非常聪明的，但是就是太贪玩了，英语单词读几遍以为自己就记住了，结果考试单词默写一塌糊涂，英语老师找我好几次了，真是头大。

为了看他到底是不是真的掌握了，我决定设计一个试卷给他。

数据源：三年级下册（人教版）总共85个单词。我把6个单元的的单词存入一个数组，然后每次随机抽20个给他，每个单词总共测试2次。

代码部分，主要作用写在备注中了：

Sub Hanyi()

Dim sht As Worksheet
Dim i, j, m, s, k, ad
Dim arr, brr(), crr()
Dim d
Set d = CreateObject("scripting.dictionary")
'存放单词的Sheet都是以Unit开头，而且有单词，读音，含义三行组成的“四线三格”本
'以下程序主要是把中文含义的行存入数组brr
m = 0
For Each sht In Sheets
    If Left(sht.Name, 1) = "U" Then
    arr = sht.UsedRange
        For i = 1 To UBound(arr)
            If Left(CStr(arr(i, 1)), 2) = "含义" Then
                m = m + 1
                ReDim Preserve brr(1 To m)
                brr(m) = Trim(Mid(arr(i, 1), 4, 8))
                'Debug.Print brr(m)
            End If
        Next i
    End If
Next


'Sheets("Summary").[a1].Resize(m, 1) = Application.Transpose(brr)
'Debug.Print UBound(brr)

'以下程序是随机抽取20个
'第一层可以尽量放大一些，这样随机覆盖的时候可以每个单词尽快被抽取到
'这里需要使用字典，尤其是唯一值，新值的字典经典应用d(s)="",d(s)=s的配合

m = 0
On Error Resume Next
For i = 1 To 1000
    s = brr(Int(Rnd() * 86))
    For k = 1 To 85
      If Sheets("Summary").Cells(k, 1) = s Then
      ad = k
      Debug.Print ad
      Exit For
      End If
    Next k
    If d(s) = "" Then
        d(s) = s
        If CInt(Sheets("Summary").Cells(ad, 2)) <= 1 Then
            m = m + 1
               ReDim Preserve crr(1 To m)
                If m <= 20 Then
                    crr(m) = s
                    For j = 1 To 85
                    If Sheets("Summary").Cells(j, 1) = s Then Sheets("Summary").Cells(j, 2) = Sheets("Summary").Cells(j, 2) + 1
                    Next
                Else
                Exit For
                End If
        End If
    End If
Next

'Sheets("Summary").[b1].Resize(m, 1) = Application.Transpose(crr)
'以下程序主要是为了写入试卷固定位置

Sheets("test").Range("C7:C16").Clear
Sheets("test").Range("g7:g16").Clear
For i = 1 To 10
    Sheets("Test").Cells(6 + i, 3) = crr(i)
Next

For i = 1 To 10
    Sheets("Test").Cells(6 + i, 7) = crr(10 + i)
Next
'以下记录几次可以测试完，85个单词，测试2次，需要9张试卷

Sheets("Test").Cells(21, 9) = Sheets("Test").Cells(21, 9) + 1
[7:16].VerticalAlignment = xlBottom


End Sub

结语：下次我准备试试在Access中给他把数学的知识点全部列上去，然后检查他是否掌握了，原理应该可以参考这次英语的原理，一起加油吧！