已知某年段學(xué)生期末成績(jī)表如圖，現(xiàn)需寫(xiě)一個(gè)可按學(xué)號(hào)查詢(xún)學(xué)生成績(jī)的宏，要求如下：

1）支持一次查詢(xún)多個(gè)學(xué)號(hào)記錄

2）反饋查詢(xún)結(jié)果，結(jié)果分查到和未查到兩種情況3）為每條查詢(xún)到的成績(jī)記錄單獨(dú)創(chuàng)建一個(gè)WorkBook來(lái)保存并按學(xué)號(hào)加日期命名文件，保存成績(jī)的工作表按學(xué)號(hào)命名。

‘

'源代碼

第三講 例子.rar

'按學(xué)號(hào)批量查詢(xún)成績(jī)

Sub SearchScoreBySn()

Dim intR As Integer '行號(hào)

Dim intC As Integer '列號(hào)

Dim Col_SearchSn As New Collection '查詢(xún)學(xué)號(hào)集合

Dim intColIndex As Integer '集合下標(biāo)

Dim Dic_Score   As Object '成績(jī)字典

Dim strSerRes As String '查詢(xún)結(jié)果

Dim Wb_SerRec As Workbook '保存查詢(xún)記錄工作簿

Dim Ws_SerRec As Worksheet '保存查詢(xún)記錄工作表

Dim strFileName As String '保存文件名

'>>>讀取查詢(xún)學(xué)號(hào)>>>

intR = 2

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

    Col_SearchSn.Add Sheet2.Cells(intR, 1) '添加到查詢(xún)學(xué)號(hào)集合

    intR = intR + 1

Loop

'<<<讀取查詢(xún)學(xué)號(hào)

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

intR = 2

Set Dic_Score = CreateObject("scripting.dictionary")

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

    Dic_Score.Add CStr(Sheet1.Cells(intR, 1)), intR '以學(xué)號(hào)為關(guān)鍵字，學(xué)號(hào)所在行為值

    intR = intR + 1

Loop

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

'>>>查詢(xún)成績(jī)并輸出>>>

For intColIndex = 1 To Col_SearchSn.Count

    If Dic_Score.exists(CStr(Col_SearchSn(intColIndex))) Then '查詢(xún)指定學(xué)號(hào)的成績(jī)是否存在

       strSerRes = "查到"

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

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

       Ws_SerRec.Name = CStr(Col_SearchSn(intColIndex)) '工作表名稱(chēng)命名為學(xué)號(hào)

       intC = 1

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

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

          Ws_SerRec.Cells(1, intC) = Sheet1.Cells(1, intC) '把成績(jī)表的標(biāo)題字段賦值到ws_serrec第一行

          Ws_SerRec.Cells(2, intC) = Sheet1.Cells(intR, intC) '把成績(jī)表的數(shù)據(jù)賦值到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 '反饋查詢(xún)結(jié)果

Next intColIndex

'<<<查詢(xún)成績(jī)并輸出<<<

End Sub