求助：VBA跨工作簿条件查询多个目标生成绩

game178

1.每个工作薄里面工作表不一，但都有成绩表，而且里面列标题都一致

2.联合班级和姓名对罗列出的目标生（此处BD列对应学生）进行多工作薄查询并集中显示

3.查询结果显示到F:s(效果如左边显示)，文件夹内有多少个工作薄，就给每位学生留出几行，如此处有3个表，就每个学生占3行

4.如虽然有3次考试，但是2中期没有查询到黄森林的成绩所以结果只显示2次，空1次

预期效果：



期待你的帮助！

game178

期待你的出手！自己顶一个

game178

参考网上资源，改写了一下，比自己想象中要麻烦些，有好的改进方法吗？




Sub cx()
    Dim MyPath$, MyName$, wb As Workbook, sh As Worksheet, sh0 As Worksheet, Arr, i, j, k
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xlsm")
    Application.ScreenUpdating = False
    On Error Resume Next
    With ThisWorkbook.Sheets
             Do While MyName <> ""
            If MyName <> ThisWorkbook.Name Then
                Set wb = GetObject(MyPath & MyName)
                sh = Sheets("成绩表")
               
                For Each sh In wb.Sheets
                    Arr = sh.Range("a2:s100")
                     For Each sh0 In Sheets
             mm = sh0.Range("F65536").End(xlUp).Row
                         For k = 2 To mm
                          For i = 1 To UBound(Arr)
                          If sh0.Cells(k, 6) = Arr(i, 1) And sh0.Cells(k, 7) = Arr(i, 2) And sh0.Cells(k, 8) = Arr(i, 4) Then
                               For j = 9 To 18
                                  sh0.Cells(k, j) = Arr(i, j - 3)
                                   sh0.Cells(k, 19) = Arr(i, 17)
                               Next j
                            End If
                          Next i
                       Next k
                      Next
                    Erase Arr
                Next
                wb.Close False
            End If
            MyName = Dir
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

game178

好像发错地方了，关闭没有找到。盖楼，停止，删除。