已知某年段學生期末成績表如圖，現(xiàn)需寫一個可按學號查詢學生成績的宏，要求如下：

1）支持一次查詢多個學號記錄

2）反饋查詢結果，結果分查到和未查到兩種情況3）為每條查詢到的成績記錄單獨創(chuàng)建一個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

'<<<讀取查詢學號

'>>>創(chuàng)建成績字典>>>

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

'<<<創(chuàng)建成績字典<<<

'>>>查詢成績并輸出>>>

For intColIndex = 1 To Col_SearchSn.Count

    If Dic_Score.exists(CStr(Col_SearchSn(intColIndex))) Then '查詢指定學號的成績是否存在

       strSerRes = "查到"

       Set Wb_SerRec = Workbooks.Add ' wb_serrec指向新創(chuàng)建工作簿

       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