已知某年段学生期末成绩表如图,现需写一个可按学号查询学生成绩的宏,要求如下:
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