已知某年段学生期末成绩表如图，现需写一个可按学号查询学生成绩的宏，要求如下：

1）支持一次查询多个学号记录

2）反馈查询结果，结果分查到和未查到两种情况3）为每条查询到的成绩记录单独创建一个WorkBook来保存并按学号加日期命名文件，保存成绩的工作表按学号命名。

‘

'源代码

第三讲 例子.rar

'按学号批量查询成绩

Sub SearchScoreBySn()

Dim intR As Integer '行号

Dim intC As Integer '列号

Dim Col_SearchSn As New Collection '查询学号集合

Dim intColIndex As Integer '集合下标

Dim Dic_Score   As Object '成绩字典

Dim strSerRes As String '查询结果

Dim Wb_SerRec As Workbook '保存查询记录工作簿

Dim Ws_SerRec As Worksheet '保存查询记录工作表

Dim strFileName As String '保存文件名

'>>>读取查询学号>>>

intR = 2

Do While (Sheet2.Cells(intR, 1) <> "") '判断是否读到最后一行

    Col_SearchSn.Add Sheet2.Cells(intR, 1) '添加到查询学号集合

    intR = intR + 1

Loop

'<<<读取查询学号

'>>>创建成绩字典>>>

intR = 2

Set Dic_Score = CreateObject("scripting.dictionary")

Do While (Sheet1.Cells(intR, 1) <> "") '判断是否读到最后一行

    Dic_Score.Add CStr(Sheet1.Cells(intR, 1)), intR '以学号为关键字，学号所在行为值

    intR = intR + 1

Loop

'<<<创建成绩字典<<<

'>>>查询成绩并输出>>>

For intColIndex = 1 To Col_SearchSn.Count

    If Dic_Score.exists(CStr(Col_SearchSn(intColIndex))) Then '查询指定学号的成绩是否存在

       strSerRes = "查到"

       Set Wb_SerRec = Workbooks.Add ' wb_serrec指向新创建工作簿

       Set Ws_SerRec = Wb_SerRec.Sheets(1) 'ws_serrec指向wb_serrec第一个工作表

       Ws_SerRec.Name = CStr(Col_SearchSn(intColIndex)) '工作表名称命名为学号

       intC = 1

       intR = Dic_Score(CStr(Col_SearchSn(intColIndex)))

       Do While (Sheet1.Cells(1, intC) <> "")

          Ws_SerRec.Cells(1, intC) = Sheet1.Cells(1, intC) '把成绩表的标题字段赋值到ws_serrec第一行

          Ws_SerRec.Cells(2, intC) = Sheet1.Cells(intR, intC) '把成绩表的数据赋值到ws_serrec第二行

          intC = intC + 1

       Loop

       strFileName = "D:" & CStr(Col_SearchSn(intColIndex)) & "_" & Date & ".xlsx"

       Wb_SerRec.SaveAs strFileName

       Wb_SerRec.Close

    Else

       strSerRes = "未查到"

    End If

    Sheet2.Cells(intColIndex + 1, 2) = strSerRes '反馈查询结果

Next intColIndex

'<<<查询成绩并输出<<<

End Sub