[已解决]ADO多文件、多表 合并、汇总-无标题行

LMY123

ADO多文件、多表 合并、汇总-无标题行.rar (20.96 KB, 下载次数: 47)

2017-4-21 09:53 上传

点击文件名下载附件

请问怎么修改代码：

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

复制代码

魂断蓝桥

Sub test()
  Dim cnn As Object, SQL As String, MyPath$, MyFile$, n As Long
  Cells.Clear
  Set cnn = CreateObject("ADODB.Connection")
  MyPath = ThisWorkbook.Path & "\"
  MyFile = Dir(MyPath & "*.xls")
  Do While MyFile <> ""
     If MyFile <> ThisWorkbook.Name Then
        n = n + 1
        If n = 1 Then
            cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=NO'; Data Source=" & MyPath & MyFile
           SQL = "SELECT * FROM [王$A3:C] WHERE F1 IS NOT NULL"
        Else
           SQL = SQL & " UNION ALL SELECT * FROM [Excel 8.0;HDR=NO;Database=" & MyPath & MyFile & "].[王$A3:C] WHERE F1 IS NOT NULL"
        End If
     End If
    MyFile = Dir()
  Loop
  Range("A2").CopyFromRecordset cnn.Execute(SQL)
  cnn.Close
  Set cnn = Nothing
End Sub

魂断蓝桥

魂断蓝桥 发表于 2017-4-21 10:27
Sub test()
  Dim cnn As Object, SQL As String, MyPath$, MyFile$, n As Long
  Cells.Clear

sql ="select f1,f2,sum(f3) from (" & sql & ") group by f1,f2"

黑魅

麻烦帮忙看一下

黑魅

魂断蓝桥 发表于 2017-4-21 10:27
Sub test()
  Dim cnn As Object, SQL As String, MyPath$, MyFile$, n As Long
  Cells.Clear

可以帮看一下吗？文件在下面