各科成绩合并汇总（感谢lsc900707版主强大易懂的代码）

vvw123

论坛有个大侠的代码，但是不会修改，一修改就出错。要求把各科成绩汇总到一个表格。--------------------------------------------------------------------------------------------------------------------
感谢lsc900707版主强大易懂的代码，他的代码接触了不少，奈何本人愚笨，学习不会进步。
下面分享下代码

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     p = ThisWorkbook.Path & ""
   
4.     f = Dir(p & "*.xls*")
   
5.     Application.ScreenUpdating = False
   
6.     Do While f <> ""
   
7.         If f <> ThisWorkbook.Name Then
   
8.             Set wb = Workbooks.Open(p & f)
   
9.             ar = wb.Sheets(1).[a1].CurrentRegion
   
10.             For i = 3 To UBound(ar)
    
11.                 For j = 6 To UBound(ar, 2)
    
12.                     s = ar(i, 5) & ar(2, j)
    
13.                     If Len(ar(i, j)) Then d(s) = ar(i, j)
    
14.                 Next
    
15.             Next
    
16.             wb.Close False
    
17.         End If
    
18.         f = Dir
    
19.     Loop
    
20.     br = [a1].CurrentRegion
    
21.     For i = 3 To UBound(br)
    
22.         For j = 6 To UBound(br, 2)
    
23.             s = br(i, 5) & br(2, j)
    
24.             br(i, j) = d(s)
    
25.         Next
    
26.     Next
    
27.     [a1].CurrentRegion = br
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "各科成绩合并完成！", 64
    
30. End Sub

复制代码

扑腾

这是咋个汇总法？你的意思是把同一个人的各科成绩集中到总表吗？

vvw123

扑腾 发表于 2019-3-13 18:38
这是咋个汇总法？你的意思是把同一个人的各科成绩集中到总表吗？

是的，就是形成一个总表，以便分析统计。

扑腾

水平比较粗糙，要求各薄的内容和排列顺序完全一致。

vvw123

扑腾 发表于 2019-3-13 21:28
水平比较粗糙，要求各薄的内容和排列顺序完全一致。

谢谢指点！手机上网，无法查看！谢谢！

lsc900707

Sub gj23w98()
    Set d = CreateObject("scripting.dictionary")
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls*")
    Application.ScreenUpdating = False
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(p & f)
            ar = wb.Sheets(1).[a1].CurrentRegion
            For i = 3 To UBound(ar)
                For j = 6 To UBound(ar, 2)
                    s = ar(i, 5) & ar(2, j)
                    If Len(ar(i, j)) Then d(s) = ar(i, j)
                Next
            Next
            wb.Close False
        End If
        f = Dir
    Loop
    br = [a1].CurrentRegion
    For i = 3 To UBound(br)
        For j = 6 To UBound(br, 2)
            s = br(i, 5) & br(2, j)
            br(i, j) = d(s)
        Next
    Next
    [a1].CurrentRegion = br
    Application.ScreenUpdating = True
    MsgBox "各科成绩合并完成！", 64
End Sub

lsc900707

参考测试附件：

jjmysjg

扑腾 发表于 2019-3-13 21:28
水平比较粗糙，要求各薄的内容和排列顺序完全一致。

第10行代码不能继续

扑腾

jjmysjg 发表于 2019-3-13 22:36
第10行代码不能继续

附件已更新，我也调试了半天，修复了一下

vvw123

lsc900707 发表于 2019-3-13 22:08
参考测试附件：

版主强大易懂的代码，是我这白丁学习的典范！谢谢！