求助！如何在同一文件夹下的所有工作部中抽取相应数据

monkeyybab

求助！
请教各位老师：如何在同一文件夹下的所有工作部中抽取相应数据，诚心学习，不胜感激

monkeyybab

里边忘加了一个 运行按钮

3190496160

Sub chaxun()
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    xh = .[b2]
    xm = .[b3]
    If xh = "" Then MsgBox "请输入姓名所在列的列号": Exit Sub
    If xm = "" Then MsgBox "请输入姓名": Exit Sub
    y = .Cells(7, Columns.Count).End(xlToLeft).Column
    If y < 4 Then MsgBox "请输入科目名称！": Exit Sub
    .UsedRange.Offset(7) = Empty
    ar = .Range(.Cells(7, 1), .Cells(100, y))
    For j = 4 To UBound(ar, 2)
        If Trim(ar(1, j)) <> "" Then
            d(Trim(ar(1, j))) = j
        End If
    Next j
    f = Dir(ThisWorkbook.Path & "\*.xls*")
    n = 1
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
            For Each sh In wb.Worksheets
                br = sh.UsedRange
                For i = 9 To UBound(br)
                    If Trim(br(i, xh)) = Trim(xm) Then
                        n = n + 1
                        ar(n, 1) = sh.Name
                        ar(n, 2) = br(2, 1)
                        ar(n, 3) = xm
                        For j = 2 To UBound(br, 2)
                            m = d(Trim(br(8, j)))
                            If m <> "" Then
                                ar(n, m) = br(i, j)
                            End If
                        Next j
                    End If
                Next i
            Next sh
            wb.Close False
        End If
    f = Dir
    Loop
    .[a7].Resize(n, UBound(ar, 2)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

成绩单.rar (62.53 KB, 下载次数: 25)

2021-1-27 17:31 上传

点击文件名下载附件

monkeyybab

3190496160 发表于 2021-1-27 17:31

老师，每行显示的分数，不用根据标题学科名称限制，只需根据姓名直接横向排列就好，可以实现吗？

3190496160

monkeyybab 发表于 2021-1-28 09:40
老师，每行显示的分数，不用根据标题学科名称限制，只需根据姓名直接横向排列就好，可以实现吗？

不知道你在说什么，更不知道你需要什么？？？
目前的代码，个人觉得最佳方案，在成绩表中科目顺序不一样的情况下，照样可以获取数据，而且，还可以自由设置科目显示的顺序，

monkeyybab

3190496160 发表于 2021-1-28 09:45
不知道你在说什么，更不知道你需要什么？？？
目前的代码，个人觉得最佳方案，在成绩表中科目顺序不一样 ...

老师，，因我个人原因，基础工作没做好，汇总格式有变化，修改不明白了 恳请再次帮助