ADO多文件、多表 合并、汇总如何支持2007以上的版本？

cjq.cn

下面这段代码如何能合并2007以上的版本？


'http://www.excelpx.com  EXCEL精英培训网范例附件
'作者 LDY ，转载请保留
'功能 实现多文件，多表汇总、合并
'引用 Microsoft ADO Ext. 2.8 for DDL and Security
'引用 Microsoft ActiveX Data Objects 2.8 Library
'引用 Microsoft Scripting Runtime

Sub addExcel()
    Dim d As New Dictionary, arr(), i As Long
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim cog As New Catalog
    Dim Sql As String
    Dim myDatePath As String
    Dim ThisExcelName As String
    Dim Dirs As String
    On Error GoTo ErrMsg
    Cells = Empty
    ThisExcelName = ThisWorkbook.Name

    Dirs = Dir(ThisWorkbook.Path & "\*.xls")
    If ThisExcelName <> Dirs Then
        myDatePath = ThisWorkbook.Path & "\" & Dirs
        d(myDatePath) = 0
    End If


    Do While Dirs <> ""
        Dirs = Dir
        If ThisExcelName <> Dirs And Dirs <> "" Then
            myDatePath = ThisWorkbook.Path & "\" & Dirs
            d(myDatePath) = 0
        End If
    Loop
    If d.Count = 0 Then MsgBox "没找到数据文件": Exit Sub

    arr = d.Keys
    d.RemoveAll

    For i = 0 To UBound(arr)
        Sql = "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & arr(i)
        cnn.Open Sql
        Set cog.ActiveConnection = cnn
        For Each Tabs In cog.Tables
            Sql = "Select * From [Excel 8.0;DATABASE=" & arr(i) & "].[" & Tabs.Name & "]"
            d(Sql) = 0
        Next
        cnn.Close
    Next

    Sql = Join(d.Keys, " UNION ALL ") & " order by 姓名"
    If MsgBox("汇总请选“是”，合并请选“否”", 4) = vbYes Then
        Sql = "SELECT  姓名, Sum(计件) AS 产量, Count(姓名) AS 工作次数 from (" & Sql & ") GROUP BY 姓名"
    End If
    cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & myDatePath
    Set rst = cnn.Execute(Sql)


    Range("e1") = "总表数 : " & d.Count
    Range("a2").CopyFromRecordset rst
    For i = 1 To rst.Fields.Count
        Cells(1, i) = rst(i - 1).Name
    Next
    MsgBox "Excel表格汇总成功！", , "表格汇总"
    Exit Sub
ErrMsg:
    MsgBox Err.Description, , "错误报告"
End Sub

mmwwdd

没使过2007,都是用2003

cjq.cn

求高手指点一下

cjq.cn

求高手指导呀

cjq.cn

求高手快出现指导一下

zhaogang1960

文件类型xls改为xlsx
Jet.OleDb.4.0改为Ace.OleDb.12.0
Excel 8.0改为Excel 12.0

zhaogang1960

代码：

1. Sub addExcel()
   
2.     Dim d As New Dictionary, arr(), i As Long
   
3.     Dim cnn As New ADODB.Connection
   
4.     Dim rst As New ADODB.Recordset
   
5.     Dim cog As New Catalog
   
6.     Dim Sql As String
   
7.     Dim myDatePath As String
   
8.     Dim ThisExcelName As String
   
9.     Dim Dirs As String
   
10.     On Error GoTo ErrMsg
    
11.     Cells = Empty
    
12.     ThisExcelName = ThisWorkbook.Name
    
13. 
    
14.     Dirs = Dir(ThisWorkbook.Path & "\*.xlsx")
    
15.     If ThisExcelName <> Dirs Then
    
16.         myDatePath = ThisWorkbook.Path & "" & Dirs
    
17.         d(myDatePath) = 0
    
18.     End If
    
19. 
    
20. 
    
21.     Do While Dirs <> ""
    
22.         Dirs = Dir
    
23.         If ThisExcelName <> Dirs And Dirs <> "" Then
    
24.             myDatePath = ThisWorkbook.Path & "" & Dirs
    
25.             d(myDatePath) = 0
    
26.         End If
    
27.     Loop
    
28.     If d.Count = 0 Then MsgBox "没找到数据文件": Exit Sub
    
29.    
    
30.     arr = d.Keys
    
31.     d.RemoveAll
    
32. 
    
33.     For i = 0 To UBound(arr)
    
34.         Sql = "Provider=Microsoft.Ace.OleDb.12.0;Extended Properties=Excel 12.0;Data Source=" & arr(i)
    
35.         cnn.Open Sql
    
36.         Set cog.ActiveConnection = cnn
    
37.         For Each Tabs In cog.Tables
    
38.             Sql = "Select * From [Excel 12.0;DATABASE=" & arr(i) & "].[" & Tabs.Name & "]"
    
39.             d(Sql) = 0
    
40.         Next
    
41.         cnn.Close
    
42.     Next
    
43. 
    
44.     Sql = Join(d.Keys, " UNION ALL ") & " order by 姓名"
    
45.     If MsgBox("汇总请选“是”，合并请选“否”", 4) = vbYes Then
    
46.         Sql = "SELECT  姓名, Sum(计件) AS 产量, Count(姓名) AS 工作次数 from (" & Sql & ") GROUP BY 姓名"
    
47.     End If
    
48.     cnn.Open "Provider=Microsoft.Ace.OleDb.12.0;Extended Properties=Excel 12.0;Data Source=" & myDatePath
    
49.     Set rst = cnn.Execute(Sql)
    
50. 
    
51. 
    
52.     Range("e1") = "总表数 : " & d.Count
    
53.     Range("a2").CopyFromRecordset rst
    
54.     For i = 1 To rst.Fields.Count
    
55.         Cells(1, i) = rst(i - 1).Name
    
56.     Next
    
57.     MsgBox "Excel表格汇总成功！", , "表格汇总"
    
58.     Exit Sub
    
59. ErrMsg:
    
60.     MsgBox Err.Description, , "错误报告"
    
61. End Sub
    

复制代码

cjq.cn

真的好感谢

huazai688

收藏学习！！！！！！！！！！！！

LMY123

ADO同夹多薄多表汇总或合并，xls及xlsx