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

zhaogang1960

1.答题前请先阅读最新规则:正式竞赛区运行规则说明

2.可跟贴直接发答案、并上传答案附件

3.题目说明:

数据源文件夹中有12个工作簿，每个工作簿中工作表数目不确定，每个同名工作表中除了第一个字段“客户名称”和最后一个字段“小计”外,字段名和字段个数不完全相同，不重复的“客户名称”不超过1000个。要求分别对所有不重复的工作表名，按照“客户名称”汇总第二个字段后的所有项目，方法不限，主程序写到模块1中，程序名为“汇总”，效果见附件。

4.评分：

按照运行速度评分，用时超过参考答an(1)20%以内的可得1分；超过参考答an(1)10%以内的可得2分；用时等于或小于参考答an(1)可得3分；用时等于小于参考答an(2)可得4分。

(以出题者测试为准)

用时参考：

测试环境：酷睿II主频2.8G，内存2G，win7+Excel2003

参考答an(1)：连续运行10次所需时间大约9.1秒

参考答an(2)：连续运行10次所需时间大约7.5秒

说明：

附件中的“字段不完全相同的多个工作簿按工作表名汇总”工作簿，从第二个工作表之后的工作表是要求的效果，不是条件，程序运行之前，除了第一张工作表外，其他工作表是没有的。

如果在Excel2007或2010中使用GetObject函数或Open方法打开数据源工作簿，速度可能比在2003要慢很多，请使用2003或使用其他方法。

Sub 测速()'连续运行10次

    Dim tt, i%

    tt = Timer

    For i = 1 To 10

        Call 汇总   '程序名

    Next

    MsgBox Timer - tt

End Sub
截至日期：2012－1－28前






该贴已经同步到 zhaogang1960的微博

KCFONG

虽然不能达标
亦献丑一下

AVEL

先交一份，本地测试失败

KCFONG

Sorry, no file attached

KCFONG

Sorry no attached file in previous post.

gdfcx

更新了，提速不大。

KCFONG

希望可达标

zm0115

这题好难，主要在速度方面的要求太严格。
投机取巧用合并计算做了一个，但也发现一个问题，合并计算，如果不打开源文件，计算后得到的结果是错误的，最多只能显示到21列数据。不知道什么原因，只要打开源文件，就正确，而且速度会快很多，实在搞不明白。

陈国华

找不到office2003来测试，按照2007测试的话肯定是比较慢的，实测最快11.83秒，配置为主频2.4G,内存2G,还请赵老师测试并告知结果，期盼中...！

wpxxsyzx

ADO方法做的
Sub 汇总1()
Dim d As New Dictionary, dzd As New Dictionary, dwj As New Dictionary, d1 As New Dictionary
Dim MyFile As String, MyPath As String, sql As String, bm As String, LJ As String
Dim cnn As New ADODB.Connection
Dim rst As ADODB.Recordset, rst1 As ADODB.Recordset
Dim sht As Worksheet
MyPath = ThisWorkbook.Path & "\数据源\"
LJ = " from [Excel 8.0;Database=" & MyPath
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Worksheets
    If sht.Name <> "总" Then sht.Delete
Next
MyFile = Dir(ThisWorkbook.Path & "\数据源\*.xls")
Do While MyFile <> ""
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    Set rst1 = cnn.OpenSchema(adSchemaTables)
    Do While Not rst1.EOF
        bm = CStr(rst1!table_name)
        Set rst = cnn.Execute("select * " & LJ & MyFile & "].[" & bm & "]")
        If d.Exists(bm) = False Then
            Set dzd(bm) = New Dictionary
            Set dwj(bm) = New Dictionary
            Set d1(bm) = New Dictionary
            Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = Replace(bm, "$", "")
        End If
        For i = 1 To rst.Fields.Count - 2
            dwj(bm)(MyFile) = dwj(bm)(MyFile) & rst.Fields(i).Name & ","
            If dzd(bm).Exists(rst.Fields(i).Name) = False Then
                d(bm) = d(bm) & "Sum(" & rst.Fields(i).Name & "),"
                dzd(bm)(rst.Fields(i).Name) = ""
            End If
        Next
        rst1.MoveNext
    Loop
    Set cnn = Nothing
    MyFile = Dir
Loop
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=2';Data Source=" & MyPath & "01月汇总.xls"
For Each kb In d.Keys
    sql = "select 客户名称," & d(kb) & "Sum(小计) from "
    For Each k In dwj(kb).Keys
        For Each Z In dzd(kb).Keys
            If InStr(dwj(kb)(k), Z & ",") = 0 Then
                d1(kb)(k) = d1(kb)(k) & "0 as " & Z & ","
            Else
                d1(kb)(k) = d1(kb)(k) & Z & ","
            End If
        Next
        d1(kb)(k) = "select 客户名称," & d1(kb)(k) & "小计" & LJ & k & "].[" & kb & "]"
    Next
    Range("a1") = sql & "(" & Join(d1(kb).Items, " union all ") & " order by 客户名称" & ") group by 客户名称"
    dzd(kb)("小计") = ""
    With Worksheets(Replace(kb, "$", ""))
        .Range("a1") = "客户名称"
        .Range("b1").Resize(1, dzd(kb).Count) = dzd(kb).Keys
        .Range("a2").CopyFromRecordset cnn.Execute(sql & "(" & Join(d1(kb).Items, " union all ") & " order by 客户名称" & ") group by 客户名称")
    End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set cnn = Nothing
End Sub

Sub 汇总2()
Dim cat As New ADOX.Catalog
Dim d As New Dictionary, dzd As New Dictionary, dwj As New Dictionary, d1 As New Dictionary
Dim MyFile As String, MyPath As String, sql As String, bm As String, LJ As String
Dim cnn As New ADODB.Connection
Dim rst As ADODB.Recordset
Dim sht As Worksheet
MyPath = ThisWorkbook.Path & "\数据源\"
LJ = " from [Excel 8.0;Database=" & MyPath
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Worksheets
    If sht.Name <> "总" Then sht.Delete
Next
MyFile = Dir(ThisWorkbook.Path & "\数据源\*.xls")
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=2';Data Source=" & MyPath & "01月汇总.xls"
Do While MyFile <> ""
    cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
    For Each tb In cat.Tables
        bm = CStr(tb.Name)
        Set rst = cnn.Execute("select * " & LJ & MyFile & "].[" & bm & "]")
        If d.Exists(bm) = False Then
            Set dzd(bm) = New Dictionary
            Set dwj(bm) = New Dictionary
            Set d1(bm) = New Dictionary
            Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = Replace(bm, "$", "")
        End If
        For i = 1 To rst.Fields.Count - 2
            dwj(bm)(MyFile) = dwj(bm)(MyFile) & rst.Fields(i).Name & ","
            If dzd(bm).Exists(rst.Fields(i).Name) = False Then
                d(bm) = d(bm) & "Sum(" & rst.Fields(i).Name & "),"
                dzd(bm)(rst.Fields(i).Name) = ""
            End If
        Next
    Next
    MyFile = Dir
Loop
For Each kb In d.Keys
    sql = "select 客户名称," & d(kb) & "Sum(小计) from "
    For Each k In dwj(kb).Keys
        For Each Z In dzd(kb).Keys
            If InStr(dwj(kb)(k), Z & ",") = 0 Then
                d1(kb)(k) = d1(kb)(k) & "0 as " & Z & ","
            Else
                d1(kb)(k) = d1(kb)(k) & Z & ","
            End If
        Next
        d1(kb)(k) = "select 客户名称," & d1(kb)(k) & "小计" & LJ & k & "].[" & kb & "]"
    Next
    Range("a1") = sql & "(" & Join(d1(kb).Items, " union all ") & " order by 客户名称" & ") group by 客户名称"
    dzd(kb)("小计") = ""
    With Worksheets(Replace(kb, "$", ""))
        .Range("a1") = "客户名称"
        .Range("b1").Resize(1, dzd(kb).Count) = dzd(kb).Keys
        .Range("a2").CopyFromRecordset cnn.Execute(sql & "(" & Join(d1(kb).Items, " union all ") & " order by 客户名称" & ") group by 客户名称")
    End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set cnn = Nothing
End Sub