已知某年段學(xué)生期末成績表如圖，現(xiàn)需寫一個(gè)可按學(xué)號查詢學(xué)生成績的宏，要求如下：
1）支持一次查詢多個(gè)學(xué)號記錄
2）反饋查詢結(jié)果，結(jié)果分查到和未查到兩種情況3）為每條查詢到的成績記錄單獨(dú)創(chuàng)建一個(gè)WorkBook來保存并按學(xué)號加日期命名文件，保存成績的工作表按學(xué)號命名。
‘
'源代碼
第三講 例子.rar
'按學(xué)號批量查詢成績
Sub SearchScoreBySn()
Dim intR As Integer '行號
Dim intC As Integer '列號
Dim Col_SearchSn As New Collection '查詢學(xué)號集合
Dim intColIndex As Integer '集合下標(biāo)
Dim Dic_Score As Object '成績字典
Dim strSerRes As String '查詢結(jié)果
Dim Wb_SerRec As Workbook '保存查詢記錄工作簿
Dim Ws_SerRec As Worksheet '保存查詢記錄工作表
Dim strFileName As String '保存文件名
'>>>讀取查詢學(xué)號>>>
intR = 2
Do While (Sheet2.Cells(intR, 1) <> "") '判斷是否讀到最后一行
Col_SearchSn.Add Sheet2.Cells(intR, 1) '添加到查詢學(xué)號集合
intR = intR + 1
Loop
'<<<讀取查詢學(xué)號
'>>>創(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 '以學(xué)號為關(guān)鍵字，學(xué)號所在行為值
intR = intR + 1
Loop
'<<<創(chuàng)建成績字典<<<
'>>>查詢成績并輸出>>>
For intColIndex = 1 To Col_SearchSn.Count
If Dic_Score.exists(CStr(Col_SearchSn(intColIndex))) Then '查詢指定學(xué)號的成績是否存在
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)) '工作表名稱命名為學(xué)號
intC = 1
intR = Dic_Score(CStr(Col_SearchSn(intColIndex)))
Do While (Sheet1.Cells(1, intC) <> "")
Ws_SerRec.Cells(1, intC) = Sheet1.Cells(1, intC) '把成績表的標(biāo)題字段賦值到ws_serrec第一行
Ws_SerRec.Cells(2, intC) = Sheet1.Cells(intR, intC) '把成績表的數(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 '反饋查詢結(jié)果
Next intColIndex
'<<<查詢成績并輸出<<<
End Sub
關(guān)注樓主