用VBA汇总多张工作簿

mengcheng001

要求汇总多张工作簿中的“金额”合计行的数据和各项目名称至汇总表内，各表内行数不确定，100多张工作簿！

zhaogang1960

请参考：

1. Sub Macro1()
   
2.     Dim Fso As Object, File As Object
   
3.     Dim cnn As Object, rs As Object, SQL$
   
4.     Dim arr(), m&
   
5.     Application.ScreenUpdating = False
   
6.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set cnn = CreateObject("adodb.connection")
   
8.     ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path & "\汇总示意表").Files.Count, 1 To 2)
   
9.     For Each File In Fso.GetFolder(ThisWorkbook.Path & "\汇总示意表").Files
   
10.         If File.Name Like "*.xlsx" Then
    
11.             m = m + 1
    
12.             If m = 1 Then cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & File
    
13.             SQL = "select f1 from [Excel 12.0;hdr=no;Database=" & File & ";].[Sheet1$c2:c2]"
    
14.             Set rs = cnn.Execute(SQL)
    
15.             arr(m, 1) = rs.Fields(0)
    
16.             SQL = "select sum(f1) from [Excel 12.0;hdr=no;Database=" & File & ";].[Sheet1$F4:H] where f3 is not null"
    
17.             Set rs = cnn.Execute(SQL)
    
18.             arr(m, 2) = rs.Fields(0)
    
19.         End If
    
20.     Next
    
21.     ActiveSheet.UsedRange.Offset(1).ClearContents
    
22.     [a2].Resize(m, 2) = arr
    
23.     Set File = Nothing
    
24.     Set Fso = Nothing
    
25.     rs.Close
    
26.     cnn.Close
    
27.     Set rs = Nothing
    
28.     Set cnn = Nothing
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

zhaogang1960

采用ADO+数组法，不需要逐个Open工作簿，特别是需要汇总的工作簿较多的情况，速度较快
请测试附件
新建文件夹.rar (83.16 KB, 下载次数: 191)

2014-12-19 19:43 上传

点击文件名下载附件

ammyc

好好学习，天天向善

mengcheng001

zhaogang1960 发表于 2014-12-19 19:44
采用ADO+数组法，不需要逐个Open工作簿，特别是需要汇总的工作簿较多的情况，速度较快
请测试附件

代码太高端了，完全看不懂，不过很谢谢你！

jjmysjg

zhaogang1960 发表于 2014-12-19 19:44
采用ADO+数组法，不需要逐个Open工作簿，特别是需要汇总的工作簿较多的情况，速度较快
请测试附件

zhaogang1960版主：
能来个字典的吗？
谢谢

zhaogang1960

jjmysjg 发表于 2014-12-23 16:22
zhaogang1960版主：
能来个字典的吗？
谢谢

不需要用字典，数组就够了
另外问一句，你不想用ADO，要逐个打开工作簿 取值？

zhaogang1960

常规法请参考：

1. Sub 常规法()
   
2.     Dim Fso As Object, f As Object, arr(), m&
   
3.     Application.ScreenUpdating = False
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path & "\汇总示意表").Files.Count, 1 To 2)
   
7.     For Each f In Fso.GetFolder(ThisWorkbook.Path & "\汇总示意表").Files
   
8.         If f.Name Like "*.xlsx" Then
   
9.             m = m + 1
   
10.             With GetObject(f)
    
11.                 arr(m, 1) = .Sheets(1).[c2]
    
12.                 arr(m, 2) = .Sheets(1).Cells(Rows.Count, 6).End(xlUp)
    
13.                 .Close 0
    
14.             End With
    
15.         End If
    
16.     Next
    
17.     ActiveSheet.UsedRange.Offset(1).ClearContents
    
18.     [a2].Resize(m, 2) = arr
    
19.     Set f = Nothing
    
20.     Set Fso = Nothing
    
21.     Application.ScreenUpdating = True
    
22. End Sub
    

复制代码

zhaogang1960

请测试附件
新建文件夹.rar (83.01 KB, 下载次数: 100)

2014-12-23 16:31 上传

点击文件名下载附件

29151429

学习啦