|
他的数据表是这样的： 
求助要求，谢谢：
1、打开用户选择的要汇总的excel文件（要求让用户选择某个文件，出现打开对话框），如本例中的《(行政班20231120)高一期中考试-高一年级学生成绩》
2、汇总各分表的成绩到此，结果如下......
他这个要求看起来挺简单，（我记得我们分享过一个类似的案例，但找了半天没找到）但做起来却还是花了点功夫，主要是我不想借用他现成的汇总表表头结构，汇总结果是写到一张空白的工作表中的（写入前先清除目标工作表所有数据）。基本思路： 2、循环待汇总的数据源工作簿，把工作表名称存入数组arrTitle，作为汇总表头字段。3、循环工作簿，依次读取每个工作表（科目）的信息，把学号、姓名等字段连起来作为字典的key，定义一个数组arrTem存放汇总数据。4、最后，循环字典的item，把数据逐行写入工作表。
1、在模块1里，sumScore过程： Sub sumScore() Dim ws As Worksheet, wb As Workbook Dim arr(), arrTem(), arrTitle() Dim sourceFile As String Dim dic As Object, dKey As String Dim arrPos As Integer, arrTemPos As Integer, lastRow As Integer, lastCol As Integer Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") With Application.FileDialog(msoFileDialogFilePicker) .Title = "请选择汇总文件......" .InitialFileName = ThisWorkbook.FullName .InitialFileName = "" .AllowMultiSelect = False .Filters.Clear .Filters.Add "Excel Files", "*.xlsm;*.xlsx;*.xls" .Filters.Add "All Files", "*.*" If .Show = -1 Then sourceFile = .SelectedItems(1) Else MsgBox "请选择汇总文件!" Exit Sub End If End With Set wb = Workbooks.Open(sourceFile) k = 5 For Each ws In wb.Worksheets ReDim Preserve arrTitle(1 To 1, 1 To k) arrTitle(1, k) = ws.Name k = k + 1 Next For Each ws In wb.Worksheets lastRow = ws.UsedRange.Rows.Count lastCol = ws.UsedRange.Columns.Count arr = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol)) If ws.Index = 1 Then For i = 1 To 4 arrTitle(1, i) = arr(1, i) Next End If arrTemPos = Pxy(arrTitle, ws.Name, 2) arrPos = Pxy(arr, "得分", 2) For i = 2 To UBound(arr) dKey = "" For j = 1 To 4 dKey = dKey & arr(i, j) & "|" Next If Not dic.exists(dKey) Then ReDim arrTem(1 To UBound(arrTitle, 2)) For j = 1 To 4 arrTem(j) = arr(i, j) Next Else arrTem = dic(dKey) End If arrTem(arrTemPos) = arr(i, arrPos) dic(dKey) = arrTem Next Next wb.Close savechanges:=False Set ws = ThisWorkbook.Sheets("Sheet1") With ws .Cells.Clear .Cells(1, 1).Resize(1, UBound(arrTitle, 2)) = arrTitle k = 2 For Each Item In dic.items .Cells(k, 1).NumberFormat = "@" .Cells(k, 1).Resize(1, UBound(Item)) = Item k = k + 1 Next End With Application.ScreenUpdating = True ThisWorkbook.Save MsgBox "Done!"End Sub
（2）line9~23，启动选择文件对话框，选择需要汇总的文件。（4）line25~30，循环工作簿，把所有工作表的名称，也就是学科名称存到数组中，将来作为汇总表表头字段，也会用于定位数据写入数组的位置。（5）line31~58，循环工作簿，把每个工作表数据装入数组arr，再循环arr把每个学生的成绩写入数组arrTem，并装入字典。（A）line35~39，把明细表的表头前4列学生信息写入数组arrTitle，表头信息填写完整。 （B）line41，arrTemPos，取得当前工作名（也就是学科名）在数组arrTitle中的位置，作为写入数组时的下标，我们不需要直接指定是“语文“，还是“数学”。 （C）line42~57，循环arr，把数据写入数组并装入字典。我们把arr前4个字段连起来作为字典的key，如果不存在此key，我们就定义一个跟表头字段数量一样大小的数组arrTem，写入前4个字段，均为学生信息；如果已存在，我们就把对应的字典item赋值给数组arrTem。line55，把得分写入arrTem; line56，把arrTem再装回字典中 （6）line59，数据读取完毕，关闭前面打开的工作簿。（A）line63，写入表头。 （B）line64~69，循环字典的item，把每个item逐行写入工作表。 Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0) '********************************** 'arrType=0,表示一维数组 'arrType=1,表示二维数组，查找第一列 'arrType=2,表示二维数组，查找第一行 '********************************** k = 0 t = 0 Select Case arrType Case Is = 0 For i = LBound(arr) To UBound(arr) k = k + 1 If arr(i) = FieldName Then t = 1 Exit For End If Next Case Is = 1 For i = LBound(arr, 1) To UBound(arr, 1) k = k + 1 If arr(i, 1) = FieldName Then t = 1 Exit For End If Next Case Is = 2 For i = LBound(arr, 2) To UBound(arr, 2) k = k + 1 If arr(1, i) = FieldName Then t = 1 Exit For End If Next End Select If t = 1 Then Pxy = k Else Pxy = 0 End IfEnd Function
代码解析：数组字段定位，根据字段名称来取得数组下标，比直接写数字要灵活。3、在工作表“Sheet1”里，cmdSum命令按钮：Private Sub CmdSum_Click() Call sumScoreEnd Sub
| 安利小店
安利的牙膏非常不错，用了以后就不想再用其他的了；洗洁精、洗衣液也是日常必备，用过都说好！ | | 合谷医疗
合谷医疗专攻各种疑难杂症，尤其擅长腰颈椎疾病、儿童神经发育异常、多动症、自闭孤独症治疗，可谓神乎其技！体验过的直呼早点来就好了！ |
喜欢就点个赞、点在看、留言评论、分享一下呗！感谢支持！ 案例文件分享说明：
|
