字段不完全相同的多个工作簿按工作表名汇总[已小结]

minjiwei

版主，
这是我的答案，用了Consolidate方法，速度远远达不到要求。运行一次就要10几秒了。想要用字典和数组，单单遍历完文件10次就已经20几秒了。不知道版主用的什么办法。待答案出来，版主要好好讲解讲解啊。


windows xp+excel2003

jspta

zhaogang1960 发表于 2012-2-1 10:52
速度还可以，就是结果不正确：

结果是因为很多代码调整过了，还没修改，就测试了速度。我这里测试时10-11秒，我2003和2010共存的，可能是因为这个原因。谢谢老师指正！

jspta

平均时间在7.78左右。用字典+ADO做的。字典上周刚学的，ADO只会点皮毛。呵呵
原来的OPEN方法大概是14秒左右。打开xls就花了10秒。

update3文件,修改了未添加cnn.close问题，时间大约是7.5左右

遇到几个问题，请版主有空的时候解惑下

1          'HDR 设置为no获得不到第一行数据，除了A1的值，其它为什么都为空？
          RSScount = RSS.Fields.Count - 1
          ReDim arrColName(0 To RSScount)
          For j = 0 To RSScount
            arrColName(j) = RSS.Fields(j).Name
          Next

Simon_Zhu

希望这次没有审错题，有心理阴影了...

期待赵版精彩的小结。

wcymiss

ADO取数，然后字典处理。

1. Sub 汇总()
   
2.     '引用Microsoft ADO Ext. 2.8 for DDL and Security
   
3.     '引用Microsoft ActiveX Data Objects 2.8 Library
   
4.     '引用Microsoft Scripting Runtime
   
5.     Dim cat As New ADOX.Catalog, tb As New ADOX.Table
   
6.     Dim cnn As New ADODB.Connection, rst As New ADODB.Recordset
   
7.     Dim d As New Dictionary, sh As Worksheet
   
8.     Dim p As String, a As String, s As String, fdna As String
   
9.     Dim h As Integer, i As Integer, j As Integer
   
10.     Dim dnum As Integer, dn As Integer
    
11.     Dim tbrr(), arr, brr(1000, 255), fdrr(1 To 256), khrr(1000), xjrr(1000)
    
12.     Dim dk, di, x As Integer, y As Integer
    
13.     Dim hrr(), lrr(), xrr(), xhrr(), xlrr()
    
14.     Application.ScreenUpdating = False
    
15.     p = ThisWorkbook.Path & "\数据源" '路径
    
16.     cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source=" & ThisWorkbook.FullName
    
17.     a = Dir(p & "*.xls") '数据源表名
    
18.     brr(0, 0) = "客户名称" '结果表模板数组
    
19.     Do While Len(a)
    
20.         cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source=" & p & a
    
21.         For Each tb In cat.Tables
    
22.             If tb.Type = "TABLE" Then '表类型容错
    
23.             s = tb.Name
    
24. '----------------------------------------------------------------------------
    
25. '|          测试了s不论是带撇号还是不带撇号，from [ s ] 都没有问题          |
    
26. '|          测试的不多，还请老师指正我这一说法                              |
    
27. '|          还有，不明白老师上次的代码为什么要判断s的最后是否是"$"          |
    
28. '|          在什么情况下，s的后面不是"$"呢？                                |
    
29. '============================================================================
    
30.             If Not d.Exists(s) Then
    
31.                 dnum = dnum + 1
    
32.                 d(s) = dnum 'key为表名，item为表名序号
    
33.                 ReDim Preserve tbrr(1 To dnum) '结果表
    
34.                 ReDim Preserve hrr(1 To dnum) '行字段字典
    
35.                 ReDim Preserve lrr(1 To dnum) '列字段字典
    
36.                 ReDim Preserve xrr(1 To dnum) '小计列
    
37.                 ReDim Preserve xhrr(1 To dnum) '行字段序号
    
38.                 ReDim Preserve xlrr(1 To dnum) '列字段序号
    
39.                 tbrr(dnum) = brr '复制结果表模板
    
40.                 Set hrr(dnum) = New Dictionary
    
41.                 Set lrr(dnum) = New Dictionary
    
42.                 xrr(dnum) = xjrr '复制小计列模板
    
43.             End If
    
44.             dn = d(s) '取出当前表名的序号
    
45.             Set rst = cnn.Execute("select * from [Excel 8.0;Database=" & p & a & "].[" & s & "]")
    
46.             arr = rst.GetRows '取数据到数组
    
47.             x = UBound(arr)
    
48.             For i = 1 To x - 1 '循环行字段，去除“客户名称”和“小计”
    
49.                 fdna = rst.Fields(i).Name '字段名赋值给变量，以减少rst对象的调用
    
50.                 If Not hrr(dn).Exists(fdna) Then
    
51.                     xhrr(dn) = xhrr(dn) + 1 '第四个是行字段的序号
    
52.                     hrr(dn)(fdna) = xhrr(dn) '行字段字典：key为行字段，item为其序号
    
53.                     tbrr(dn)(0, xhrr(dn)) = fdna '将行字段赋值给结果数组
    
54.                 End If
    
55.                 fdrr(i) = hrr(dn)(fdna) '为避免频繁调用字典对象，另用一个数组储存当前表字段对应的序号
    
56.             Next
    
57.             For j = 0 To UBound(arr, 2) '处理列字段（客户）
    
58.                 If Not lrr(dn).Exists(arr(0, j)) Then
    
59.                     xlrr(dn) = xlrr(dn) + 1
    
60.                     lrr(dn)(arr(0, j)) = xlrr(dn)
    
61.                     tbrr(dn)(xlrr(dn), 0) = arr(0, j)
    
62.                 End If
    
63.                 khrr(j) = lrr(dn)(arr(0, j)) '另用一个数组储存当前表客户对应的序号
    
64.             Next
    
65.             For j = 0 To UBound(arr, 2)
    
66.                 For i = 1 To x - 1 '数据求和
    
67.                     If IsNull(arr(i, j)) Then arr(i, j) = 0
    
68.                     tbrr(dn)(khrr(j), fdrr(i)) = arr(i, j) + tbrr(dn)(khrr(j), fdrr(i))
    
69.                 Next
    
70.                 xrr(dn)(khrr(j)) = arr(x, j) + xrr(dn)(khrr(j)) '小计
    
71.             Next
    
72.             End If
    
73.         Next
    
74.         a = Dir
    
75.     Loop
    
76.     dk = d.Keys
    
77.     di = d.Items
    
78.     For i = 0 To UBound(dk)
    
79.         If dk(i) Like "'*'" Then '判断是否有撇号
    
80.             s = Mid(dk(i), 2, Len(dk(i)) - 3)
    
81.         Else
    
82.             s = Left(dk(i), Len(dk(i)) - 1)
    
83.         End If
    
84.         On Error Resume Next
    
85.         Set sh = Sheets(s)
    
86.         If Err.Number <> 0 Then
    
87.             Err.Clear
    
88.             Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
    
89.             sh.Name = s
    
90.         Else
    
91.             sh.Cells.ClearContents
    
92.         End If
    
93.         h = di(i)
    
94.         x = xlrr(h)
    
95.         y = xhrr(h)
    
96.         tbrr(h)(0, y + 1) = "小计"
    
97.         For j = 1 To x + 2
    
98.             tbrr(h)(j, y + 1) = xrr(h)(j) '添加小计列到结果表
    
99.         Next
    
100.         sh.Range("a1").Resize(x + 3, y + 2) = tbrr(h)
     
101.     Next
     
102.     cnn.Close
     
103.     Set d = Nothing
     
104.     Set tb = Nothing
     
105.     Set rst = Nothing
     
106.     Set cnn = Nothing
     
107.     Set cat = Nothing
     
108.     Set sh = Nothing
     
109.     Application.ScreenUpdating = True
     
110. End Sub

复制代码

zm0115

2011年农历最后一天交作业，字典+数组实在是用的不好，2012年要加油努力了。
祝赵老师以及各位前辈、朋友新年快乐，龙年吉祥。

xmyjk

翻查了下ADOX对象的说明，发现ADOX居然支持取表内字段的名称，干脆全部用ADO做了。好处就是不用开表。坏处就是貌似汇总语句的效率不高，可能我SQL语句写复杂了吧。。。

------------------------------------------------------
多谢赵老师指正，修改了下SQL语句，整整提高了6秒，看来IIF真的很浪费效率。。。

[code=vb]
Option Explicit
Sub 汇总()
    Dim Cat As New ADOX.Catalog, Myfile As String, Mypath As String
    Dim i As Integer, d As New Dictionary, arr, j&, k&, m&, s As String
    Dim tj(1 To 50, 1 To 3), dc(1 To 50) As New Dictionary, dd As New Dictionary
    Dim Cn As New ADODB.Connection, Wb, sh As Worksheet
    Dim tnm As String, cnm As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "总" Then sh.Delete
    Next
    Application.DisplayAlerts = True
    Mypath = ThisWorkbook.Path & "\数据源\"
    Myfile = Dir(Mypath & "\*.xls")
    Do While Myfile <> ""
        With Cat
            .ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source=" & Mypath & Myfile
            For j = 0 To .Tables.Count - 1
                With .Tables(j)
                    If .Type = "TABLE" Then
                        tnm = .Name
                        If d.Exists(tnm) Then
                            tj(d(tnm), 2) = tj(d(tnm), 2) & "|" & Myfile
                            s = ""
                            For k = 0 To .Columns.Count - 1
                                With .Columns(k)
                                    cnm = .Name
                                    If cnm <> "小计" Then
                                        If Not dc(d(tnm)).Exists(cnm) Then
                                            dc(d(tnm))(cnm) = 0
                                            tj(d(tnm), 3) = tj(d(tnm), 3) & " sum(" & cnm & "),"
                                        End If
                                        s = s & cnm & ","
                                    End If
                                End With
                            Next
                            dd(Myfile & Split(tnm, "$")(0)) = s & ","
                        Else
                            m = m + 1
                            d(tnm) = m
                            tj(m, 1) = Split(tnm, "$")(0)
                            tj(m, 2) = Myfile
                            s = ""
                            For k = 0 To .Columns.Count - 1
                                With .Columns(k)
                                    cnm = .Name
                                    dc(m)("客户名称") = 0
                                    If cnm <> "小计" Then
                                        If cnm <> "客户名称" Then
                                            dc(m)(cnm) = 0
                                            tj(m, 3) = tj(m, 3) & " sum(" & cnm & "),"
                                        Else
                                            tj(m, 3) = "客户名称," & tj(m, 3)
                                        End If
                                        s = s & cnm & ","
                                    End If
                                End With
                            Next
                            dd(Myfile & Split(tnm, "$")(0)) = s & ","
                        End If
                    End If
                End With
            Next
        End With
        Set Cat = Nothing
        Myfile = Dir
    Loop
    Set d = Nothing
    Dim brr, sql As String
   
    For i = 1 To m
        dc(i)("小计") = 0
        tj(i, 3) = tj(i, 3) & " sum(小计) "
        arr = dc(i).Keys
        Set dc(i) = Nothing
        Wb = Split(tj(i, 2), "|")
        ReDim brr(0 To UBound(Wb))
        Cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0';Data Source=" & Mypath & Wb(0)
        For j = 0 To UBound(Wb)
            For k = 0 To UBound(arr) - 1
                If InStr(dd(Wb(j) & tj(i, 1)), arr(k) & ",") Then
                    brr(j) = brr(j) & arr(k) & ","
                Else
                    brr(j) = brr(j) & "0 as " & arr(k) & ","
                End If
            Next
            brr(j) = " select " & Left(brr(j), Len(brr(j)) - 1) & ",小计 " _
                   & " from [Excel 8.0;DATABASE=" & Mypath & Wb(j) & "].[" & tj(i, 1) & "$] "
        Next
        sql = Join(brr, " union all ") & " ": Erase brr
        sql = "select " & tj(i, 3) & " from (" & sql & ") group by " & "客户名称 "
        With ThisWorkbook.Sheets.Add(After:=Worksheets(ThisWorkbook.Sheets.Count))
            .Name = tj(i, 1)
            .Range("a1").Resize(1, UBound(arr) + 1) = arr
            .Range("a2").CopyFromRecordset Cn.Execute(sql)
        End With
        sql = "": Cn.Close
        Erase Wb, arr
    Next
    Set Cn = Nothing: Set dd = Nothing
    Erase tj
    Sheets("总").Select
    Application.ScreenUpdating = True
End Sub

[/code]

xmyjk

用OPEN有做了一个，貌似快了一点。
补充一句话，发现一个很有趣的现象，在XP下，OPEN法，如果把任务栏的窗口都关掉，连VBE界面都不留，汇总的速度瞬间加快非常多。

[code=vb]
Sub 汇总()
    Dim dh(1 To 10) As New Dictionary, arr, brr(1 To 10), crr, i&, j&, wb As Workbook, sh As Worksheet, dsh As New Dictionary
    Dim m&, k(1 To 10) As Long, l(1 To 10) As Long, dl(1 To 10) As New Dictionary, msh As Long, r&, t&
    Dim mypath As String, myfile As String
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Visible = False
   
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "总" Then sh.Delete
    Next
    Application.DisplayAlerts = True
    mypath = ThisWorkbook.Path & "\数据源\"
    myfile = Dir(mypath & "\*.xls")
    Do While myfile <> ""
        Set wb = Workbooks.Open(mypath & myfile)
        For Each sh In wb.Sheets
            If Not dsh.Exists(sh.Name) Then
                m = m + 1
                dsh(sh.Name) = m
                msh = m
                ReDim crr(1 To 1000, 1 To 50) As Single
            Else
                msh = dsh(sh.Name)
                crr = brr(msh)
            End If
            arr = sh.UsedRange
            For i = 2 To UBound(arr)
                If Not dh(msh).Exists(arr(i, 1)) Then
                    k(msh) = k(msh) + 1
                    dh(msh)(arr(i, 1)) = k(msh)
                    r = k(msh)
                Else
                    r = dh(msh)(arr(i, 1))
                End If
                For j = 2 To UBound(arr, 2) - 1
                    If Not dl(msh).Exists(arr(1, j)) Then
                        l(msh) = l(msh) + 1
                        dl(msh)(arr(1, j)) = l(msh)
                        t = l(msh)
                    Else
                        t = dl(msh)(arr(1, j))
                    End If
                    crr(r, t) = crr(r, t) + arr(i, j)
                Next
            Next
            brr(msh) = crr
            Erase crr, arr
        Next
        wb.Close False
        Set wb = Nothing
        myfile = Dir
    Loop
    arr = dsh.Keys
    For i = 1 To m
        With ThisWorkbook.Sheets.Add(After:=Worksheets(ThisWorkbook.Sheets.Count))
            .Name = arr(i - 1)
            .Range("a1") = "客户名称"
            .Range("b1").Resize(1, l(i)) = dl(i).Keys
            .Range("a2").Resize(k(i), 1) = Application.Transpose(dh(i).Keys)
            .Range("b2").Resize(k(i), l(i)) = brr(i)
            .Cells(1, l(i) + 2) = "小计"
            .Cells(2, l(i) + 2).Resize(k(i), 1).Formula = "=sum(b2:" & Cells(2, l(i) + 1).Address(0, 0) & ")"
        End With
    Next
    Erase brr, arr, k, l, dl, dh
    Set dsh = Nothing
    Sheets("总").Select
    Application.Visible = True
    Application.ScreenUpdating = True
End Sub
[/code]

zhaogang1960

截至日期已到，谢谢各位参与答题，已测试各位代码，现将各位得分情况公布如下：

zhaogang1960

小结：


首先感谢冻版主采用此题目和在审题过程中给予的帮助
感谢所有参与答题的会员，特别感谢反复修改、优化代码的会员

一、题目说明
本题目是在常见的“字段不完全相同的多个工作簿汇总”基础上加了一个条件——“按照工作表名”，主要测试在掌握多个工作簿汇总基础上，利用字典嵌套、嵌套数组(或三维数组)按照不同工作表名汇总的综合能力，要求速度的目的是，让大家避免使用论坛上常见的每个文件打开(或连接)两次的方法。可以用打开工作簿+数组+字典VBA常规法、ADO联合查询法，也可以数组+字典和ADO混合使用。下面代码就是1楼所说的参考答an(1)（常规法），参考答an(2)（ADO联合查询法）和另有两种方法——ADO联合查询法2（OpenSchema取得工作表名）和ado+数组嵌套法已写在附件中，有兴趣者请参考并指正。

二、关于重新定义数组和ADO连接的说明
除了已经明确数量（如用户不超过1000，12个工作簿）之外，定义数组的最大下标要有根据，应避免随便定义一个固定数字（列数定义为256除外）。
用ADO法循环连接工作簿时，通常使用一个变量cnn，连接下一个工作簿前要关闭上一个连接，需要付出一定时间，如果每个工作簿都有一个连接变量cnn1、cnn2……同时连接，等到程序结束时再统一关闭连接，释放内存，这样可以大大提高速度，但是带来的就是占用内存，经与冻版主协商，并采用冻版主的建议——进行极限测试，数据源工作簿改为49个，每个工作簿只有1个40000行数据的工作表后进行测试，同时连接法在连接第27个工作簿时因内存不足报错，常规法则没有报错。每个得高分的算法都有可能成为人们解决此类问题的范例，因此，应该避免使用采用同时连接法。

1. Sub 数组嵌套()  ' 参考答an(1)
   
2. '引用Microsoft Scripting Runtime
   
3.     Dim ary(), temp, arr, brr(), k, sh As Worksheet
   
4.     Dim d As New Dictionary, ds As New Dictionary, dic As New Dictionary, dm As New Dictionary, dn As New Dictionary
   
5.     Dim myPath$, myFile$, i&, j&, lc&, shc&, shn$
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     For Each sh In Sheets
   
9.         If sh.Name <> ActiveSheet.Name Then sh.Delete '删除可能存在的已汇总工作表
   
10.     Next
    
11.     Application.DisplayAlerts = True
    
12.     myPath = ThisWorkbook.Path & "\数据源"
    
13.     myFile = Dir(myPath & "*.xls")
    
14.     Do While myFile <> ""
    
15.         Set wb = GetObject(myPath & myFile) '打开个工作簿
    
16.         For Each sh In wb.Sheets '逐表
    
17.             With sh
    
18.                 shn = .Name '表名
    
19.                 If Not d.Exists(shn) Then
    
20.                     Set d(shn) = New Dictionary '[字典嵌套]定义各工作表行汇总字典，用以记录各工作不重复“客户名称”行号
    
21.                     Set ds(shn) = New Dictionary '[字典嵌套]定义记录各工作表表头不重复项目列号字典
    
22.                     shc = shc + 1 '不重复工作表名称计数
    
23.                     ReDim Preserve ary(1 To shc) '重新定义动态数组,储存不重复工作表名对应的二维数组
    
24.                     dic(shn) = shc '不重复工作表序号
    
25.                 End If
    
26.                 arr = .[a1].CurrentRegion
    
27.                 lc = UBound(arr, 2) - 1 '不含小计列
    
28.                 For i = 1 To lc '逐列
    
29.                     If Not ds(shn).Exists(arr(1, i)) Then '统计各个工作表表头不重复项目
    
30.                         dn(shn) = dn(shn) + 1 '各个工作表表头不重复项目计数(n = n + 1)
    
31.                         ds(shn)(arr(1, i)) = dn(shn) '记录各个工作表列号
    
32.                     End If
    
33.                 Next
    
34.                 temp = ary(dic(shn)) 'ary储存的不重复工作表名对应的二维数组赋给临时变量
    
35.                 If IsArray(temp) Then '如果temp是数组，保留原数值扩展列数
    
36.                     ReDim Preserve temp(1 To 1000, 1 To ds(shn).Count)
    
37.                 Else '如果temp不是数组，则重新定义一个列数等于不重复字段数的数组赋给它
    
38.                     ReDim brr(1 To 1000, 1 To ds(shn).Count)
    
39.                     temp = brr
    
40.                 End If
    
41.                 For i = 2 To UBound(arr) '逐行数据
    
42.                     If Not d(shn).Exists(arr(i, 1)) Then '该表第i行“客户名称”字典不存在
    
43.                        dm(shn) = dm(shn) + 1 '计数
    
44.                        d(shn)(arr(i, 1)) = dm(shn) '“客户名称”添加到字典键值，不重复行数添加到字典条目
    
45.                        For j = 1 To lc '逐列(不含小计)
    
46.                          temp(dm(shn), ds(shn)(arr(1, j))) = arr(i, j)
    
47.                        Next
    
48.                     Else '该表第i行“客户名称”字典已经存在
    
49.                        For j = 2 To lc '从第二列起累加同一个工作表同一个“客户名称”的项目
    
50.                          temp(d(shn)(arr(i, 1)), ds(shn)(arr(1, j))) = temp(d(shn)(arr(i, 1)), ds(shn)(arr(1, j))) + arr(i, j)
    
51.                        Next
    
52.                     End If
    
53.                 Next
    
54.                 ary(dic(shn)) = temp '临时数组赋给ary
    
55.            End With
    
56.         Next
    
57.         wb.Close False
    
58.         myFile = Dir
    
59.     Loop
    
60.     k = d.Keys
    
61.     With Sheets
    
62.         For i = 0 To d.Count - 1 '逐个不重复工作表名
    
63.             .Add(After:=.Item(.Count)).Name = k(i) '插入一个工作表,工作表名等于该不重复工作表名
    
64.             Range("a1").Resize(, dn(k(i))) = ds(k(i)).Keys  '写表头
    
65.             Range("a2").Resize(dm(k(i)), dn(k(i))) = ary(dic(k(i))) '写数据
    
66.             Cells(1, dn(k(i)) + 1) = "小计"
    
67.             With Cells(2, dn(k(i)) + 1).Resize(dm(k(i)))
    
68.                 .FormulaR1C1 = "=SUM(RC2:RC" & dn(k(i)) & ")" '最右边小计公式
    
69.                 .Value = .Value
    
70.             End With
    
71.         Next
    
72.     End With
    
73.     Sheets(1).Activate
    
74.     Application.ScreenUpdating = True
    
75. End Sub
    

复制代码