求助：VBA分表汇总成总表（表头名称与顺序都不一致

xiangbaoan

改进.rar (42.83 KB, 下载次数: 59)

2022-10-11 08:02 上传

点击文件名下载附件

panshuying1973

小象啊啊 发表于 2022-10-10 12:41
请参考附件。

感谢小象老师

panshuying1973

MHanys 发表于 2022-10-10 15:40
见附件~~~

感谢老师帮助

panshuying1973

longming3 发表于 2022-10-10 16:18
开个工，表头随意增加，第一列内容随意改变，关键字在第一列，请测试效果

感谢老师帮助

blackttea1

学习啦，谢谢

Hontyu

国际惯例,先点赞再学习

panshuying1973

longming3 发表于 2022-10-10 16:18
开个工，表头随意增加，第一列内容随意改变，关键字在第一列，请测试效果

老师好！各位老师提供的代码我都看了并且试用了，对于我这种小白来说，感觉您写的代码有以下优点：
1.关系简单明了，可以看懂
2.运行速度快
3.可塑性强，可以根据您写的代码，改动部分内容，来适应自己的需求。
这是我好久以来学到过的最好理解的多工作簿（表头和第一列可以随意扩容的）汇总代码。
非常感谢老师的帮助！

panshuying1973

xiangbaoan 发表于 2022-10-10 19:48

老师好！您的代码运行速度很快，但是我看用了SQL数据库，这个看不太懂呢。
非常感谢老师的帮助！

panshuying1973

longming3 发表于 2022-10-10 16:18
开个工，表头随意增加，第一列内容随意改变，关键字在第一列，请测试效果

再来复习下老师的经典代码
Sub fbhz()
    myPath = ThisWorkbook.Path & "\"
    myFile = Dir(myPath & "*.xls*")
    Dim br(1 To 65536, 1 To 256)
    Application.ScreenUpdating = False
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    Do While myFile <> ""
        If myFile <> ThisWorkbook.Name Then
            Set sh = Workbooks.Open(myPath & myFile)
            ar = sh.Sheets(1).[a1].CurrentRegion
            br(1, 1) = ar(1, 1)
            For i = 2 To UBound(ar, 2)
                gjz = ar(1, i)
                If Not d1.exists(gjz) Then
                    k1 = k1 + 1
                    d1(gjz) = k1 '记录列数
                    br(1, d1(gjz) + 1) = gjz
                End If
            Next
            
            For i = 2 To UBound(ar)
                gjz = ar(i, 1)
                If Not d2.exists(gjz) Then
                    k2 = k2 + 1
                    d2(gjz) = k2
                    br(d2(gjz) + 1, 1) = gjz
                    For j = 2 To UBound(ar, 2)
                        If ar(i, j) > 0 Then br(d2(gjz) + 1, d1(ar(1, j)) + 1) = br(d2(gjz) + 1, d1(ar(1, j)) + 1) + ar(i, j)
                    Next
                Else
                    For j = 2 To UBound(ar, 2)
                        If ar(i, j) > 0 Then br(d2(gjz) + 1, d1(ar(1, j)) + 1) = br(d2(gjz) + 1, d1(ar(1, j)) + 1) + ar(i, j)
                    Next
                End If
            Next
            Workbooks(myFile).Close False
        End If
        myFile = Dir
    Loop
    ThisWorkbook.Sheets(1).[k1].Resize(k2 + 1, k1 + 1) = br
    Application.ScreenUpdating = True
End Sub

jjmysjg

标题位置不不致