跨工作簿自动汇总

西下斜阳

因为工作性质，经常要汇总下级单位数据，有110多个单位，每次到汇总时就害怕，希望能有一个汇总的工具，一键就能完成。希望各位高手相助，设计一个自动汇总的VBA程序。要求能根据汇总表的栏目，自动从文件夹中，选择相应的工作簿，并从该工作簿的指定工作表的相关单元格取数填入汇总表中，具体的要求和要达到的效果见附件 经费汇总(样表).rar (94.34 KB, 下载次数: 80)

2014-8-15 09:55 上传

点击文件名下载附件

jiminyanyan

http://club.excelhome.net/thread-1139822-1-1.html
可看一下我写的工具。。。。

西下斜阳

这个合并操作可能不适用，我平时每次都有110多个这样的工作簿

liulang0808

http://club.excelhome.net/blog-238368-1693.html
参考下这个吧，遍历文件，
workbook.open 打开文件，然后提取数据

liu-aguang

1. Sub test()
   
2.    Dim cel As Range
   
3.    Sheets("直属").Activate
   
4.     For Each cel In Range(Range("b2"), Range("b2").End(xlToRight)).Cells
   
5.         If Dir(ThisWorkbook.Path & "" & cel.Value & ".xls") <> "" Then
   
6.             With Workbooks.Open(ThisWorkbook.Path & "" & cel.Value & ".xls")
   
7.                 .Sheets(1).UsedRange.Columns(2).Offset(2).Copy cel.Offset(1)
   
8.                 .Close 0
   
9.             End With
   
10.         End If
    
11.     Next
    
12. End Sub
    

复制代码

西下斜阳

liulang0808 发表于 2014-8-15 10:44
http://club.excelhome.net/blog-238368-1693.html
参考下这个吧，遍历文件，
workbook.open 打开文件，然 ...

我是菜鸟，最好能帮我写一个代码，我再自己模仿做

liu-aguang

经费汇总(样表)v1.rar (95.9 KB, 下载次数: 306)

2014-8-15 10:54 上传

点击文件名下载附件

西下斜阳

liu-aguang 发表于 2014-8-15 10:54

非常感谢，很好用，谢谢

zhaogang1960

ADO法速度较快：

1. Sub Macro1()
   
2.     Dim Fso As Object, File As Object, cnn As Object, SQL$, m&
   
3.     Application.ScreenUpdating = False
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     ActiveSheet.UsedRange.Offset(3).ClearContents
   
6.     ActiveSheet.UsedRange.Offset(2, 1).ClearContents
   
7.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
   
8.         If File.Name Like "*.xls" And File.Name <> ThisWorkbook.Name Then
   
9.             m = m + 1
   
10.             If m = 1 Then
    
11.                 Set cnn = CreateObject("adodb.connection")
    
12.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & File
    
13.                 SQL = "select * from [清算表$a3:b]"
    
14.                 [a4].CopyFromRecordset cnn.Execute(SQL)
    
15.             Else
    
16.                 SQL = "select * from [Excel 8.0;hdr=no;Database=" & File & ";].[清算表$b3:b]"
    
17.                 Cells(4, m + 1).CopyFromRecordset cnn.Execute(SQL)
    
18.             End If
    
19.             Cells(3, m + 1) = Replace(File.Name, ".xls", "")
    
20.         End If
    
21.     Next
    
22.     Set Fso = Nothing
    
23.     cnn.Close
    
24.     Set cnn = Nothing
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

zhaogang1960

请测试附件
经费汇总(样表).rar (99.45 KB, 下载次数: 338)

2014-8-15 11:11 上传

点击文件名下载附件