关于文件汇总的个人总结

autumnalRain

>学习VBA有些时日了。由于工作内容发生变化。对VBA的需求越来越小。但出于喜欢，还是想把自己一直认为VBA最有优势的一方面例子——文件汇总类的内容贴出来，以供日后自己查询。也可以没事时候在手机上看看代码，以达到巩固和熟悉，最起码不至于过段时间看不懂。

>论坛上各位大神早已总结过的这样的内容。水平之高，不敢企及。也不敢相比。

>例子有来自己所购书上的，也有论坛其他大师的（希望各位大师开放产权哦）！

>本贴仅作为自己的笔记或总结，按照自己的标准进行归类（代码经过自己学习理解，有一定心得，容易理解）,基本上这些例子稍加修改，即可以完成目标任务。

>希望各位朋友不要回贴……

--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

本贴分几类例子（每类都以SQL方法和非SQL方法解决）

第一类：单工作簿内多工作表类汇总

第二类：同文件夹下汇总（SQL方法及其他方法）

第三类：目录文件夹及其各级子文件夹内EXCEL文件汇总

-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

几个学习贴子，后续补充中……

http://club.excelhome.net/thread-1185089-1-1.html

http://club.excelhome.net/thread-1165866-1-1.html

http://club.excelhome.net/thread-160847-1-1.html

autumnalRain

第一个例子：
分类汇总单工作簿中多工作表内容。非复制粘贴。例子来源于《千解千寻EXCEL SQL》（记不清书名了）

1. Sub 如何使用VBA进行多表汇总()
   
2.     Dim AdoConn As New ADODB.Connection
   
3.     Dim AdoRst As ADODB.Recordset
   
4.     Dim strConn As String
   
5.     Dim strSQL As String
   
6.     '设置连接字符串
   
7.     strConn = " Provider=Microsoft.ACE.OLEDB.12.0;" & _
   
8.           "Data Source=" & ThisWorkbook.FullName & _
   
9.           ";Extended Properties=""Excel 12.0;HDR=YES"";"
   
10.     '打开数据库链接
    
11.     AdoConn.Open strConn
    
12.     '获取数据库表格结构
    
13.     Set AdoRst = AdoConn.OpenSchema(adSchemaTables)
    
14.     '获取各表名称，编写SQL语句
    
15.     Do Until AdoRst.EOF
    
16.         If AdoRst!TABLE_TYPE = "TABLE" And AdoRst!TABLE_NAME <> "汇总表[        DISCUZ_CODE_0        ]quot; And (AdoRst!TABLE_NAME Like "*[        DISCUZ_CODE_0        ]quot; Or AdoRst!TABLE_NAME Like "'*
    
17. ") Then
    
18.             strSQL = strSQL & "Union All Select * From [" & AdoRst!TABLE_NAME & "] "
    
19.         End If
    
20.         AdoRst.MoveNext
    
21.     Loop
    
22.     '关闭数据记录集
    
23.     AdoRst.Close
    
24.     '重新编辑SQL语句，去掉最开头的Union All，共10个字符
    
25.     strSQL = Right(strSQL, Len(strSQL) - 10)
    
26.     '编辑SQL语句，计算应发合计的总合
    
27.     strSQL = "Select 员工编号,姓名,Sum(应发合计) as 全年应发合计 From (" & strSQL & ") Group By 员工编号,姓名"
    
28.     '执行查询
    
29.     Set AdoRst = AdoConn.Execute(strSQL)
    
30.     '将结果写入汇总表
    
31.     With Sheet1
    
32.         .Cells.Clear
    
33.         .Range("A2").CopyFromRecordset AdoRst
    
34.         '填写标题
    
35.         For i = 1 To AdoRst.Fields.Count
    
36.             .Cells(1, i) = AdoRst.Fields(i - 1).Name
    
37.         Next
    
38.         '自动调整列宽
    
39.         .UsedRange.Columns.AutoFit
    
40.         '设置边框颜色
    
41.         .UsedRange.Borders.Color = 0
    
42.         '设置标题行颜色
    
43.         '.UsedRange.Rows(1).Style = "强调文字颜色 2"
    
44.     End With
    
45.     AdoRst.Close
    
46.     '关闭数据库连接
    
47.     AdoConn.Close
    
48. End Sub

复制代码

autumnalRain

第一个例子：字典+数组方法

1. Sub test()
   
2.     Dim arr, d, sh As Object, i, k
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For Each sh In ThisWorkbook.Worksheets
   
5.         If sh.Name <> "汇总表" Then
   
6.             arr = sh.Range(sh.Range("a2"), sh.Range("c65536").End(xlUp))
   
7.             For i = LBound(arr) To UBound(arr)
   
8.                 If Not d.exists(arr(i, 1)) Then
   
9.                     Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
   
10.                 End If
    
11.                     d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + arr(i, 3)
    
12.             Next i
    
13.         End If
    
14.         Erase arr
    
15.     Next sh
    
16.     For Each k In d.keys
    
17.         Set Rng = Sheets("汇总表").Range("b1048576").End(3).Offset(1)
    
18.         Rng.Resize(d(k).Count, 2) = Application.Transpose(Array(d(k).keys, d(k).items))
    
19.         Rng.Resize(d(k).Count, 1).Offset(0, -1) = k
    
20.     Next
    
21. End Sub

复制代码

autumnalRain

第二个例子：
汇总指定文件夹下所有EXCEL工作簿中所有SHEET内容。不用分类汇总，使用复制粘贴即可.本例采用FSO方法，DIR循环方法见附件内代码。代码工作簿可以不与文件夹放在一路径下

1. Sub FSO法合并指定文件夹内所有文档()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     With Application.FileDialog(msoFileDialogFolderPicker) '运行后出现标准的选择文件夹对话框
   
5.         If .Show Then myPath = .SelectedItems(1) Else Exit Sub '如选中则返回=-1 / 取消未选则返回=0'；也可以直接指定文件夹路径如 myPath = ThisWorkbook.Path & "\分表"
   
6.     End With
   
7.     Set fso = CreateObject("scripting.filesystemobject")
   
8.     For Each file In fso.getfolder(myPath).Files
   
9.         Set Wb = Workbooks.Open(file)
   
10.         For Each sh In Wb.Sheets
    
11.             Irow = sh.Range("a65536").End(xlUp).Row
    
12.             sh.Range("a3:k" & Irow).Copy
    
13.             ThisWorkbook.Sheets(2).Range("a65536").End(3).Offset(1).PasteSpecial Paste:=xlPasteValues
    
14.         Next
    
15.         Wb.Close False
    
16.      Next
    
17.      Application.DisplayAlerts = True
    
18.      Application.ScreenUpdating = True
    
19. End Sub

复制代码

autumnalRain

第二个例子（之二）将同文件夹下多工作簿的SHEET1表汇总到一个工作簿中(本例目标工作簿为“总部”）：新建工作表，并以被汇总工作簿命名工作表

1. Sub SqlPLUSFSO()
   
2.     Set Cnn = CreateObject("adodb.connection")
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     mypath = ThisWorkbook.Path
   
5.     For Each file In fso.getfolder(mypath).Files
   
6.         If file.Name <> ThisWorkbook.Name Then
   
7.             ThisWorkbook.Worksheets.Add.Name = file.Name
   
8.             Cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=NO;imex=1';Data Source=" & ThisWorkbook.Path & "" & file.Name
   
9.             Sql = "select F1,F2 from  [sheet1$]"
   
10.             Sheets(file.Name).[a65536].End(3).CopyFromRecordset Cnn.Execute(Sql)
    
11.             Cnn.Close
    
12.         End If
    
13.     Next
    
14.     Set Cnn = Nothing
    
15. End Sub

复制代码

autumnalRain

第三类例子：汇总目标文件夹下及其各级文件夹下EXCLE文件

1. Sub SQL多文件夹下多工作簿多工作表汇总_雪山飞狐()
   
2.     Dim Fso As Object, Folder As Object, ArrFile$(), mf As Long, i As Long, x As Integer
   
3.     Dim Cnn As Object, Rs As Object, SQL As String, SheetName$
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         MyPath = .SelectedItems(1)
   
8.     End With
   
9.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
10.     Set Folder = Fso.GetFolder(MyPath)
    
11.     Call GetFiles(Folder, ArrFile, mf)
    
12.     Select Case Application.Version * 1    '根据Excel版本选择合适的连接语句
    
13.     Case Is <= 11    '03以下包括03
    
14.         strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data source="
    
15.     Case Is >= 12    '07以上包括07
    
16.         strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
17.     End Select
    
18.     Set Cnn = CreateObject("ADODB.Connection")
    
19.     With Sheets("Sheet3")
    
20.         .Cells.Clear    '清除所有内容
    
21.         For i = 1 To mf
    
22.             If ArrFile(i) <> ThisWorkbook.FullName Then    '文件不等于本文件
    
23.                 Set Cnn = CreateObject("ADODB.Connection")
    
24.                 Cnn.Open strConn & ArrFile(i)
    
25.                 Set Rs = Cnn.OpenSchema(20)    '使用OpenSchema 方法取得数据源中的所有表信息，其中20是参数adSchemaTables的值，因为采用的是后期绑定，所以只能使用adSchemaTables的值
    
26.                 Do Until Rs.EOF
    
27.                     If Rs.Fields("TABLE_TYPE") = "TABLE" Then    '判断表类型是工作表，数据库中是数据表
    
28.                         SheetName = Replace(Rs("TABLE_NAME").Value, "'", "")    '去掉可能存在的单引号，只能当工作表名中含有数字时才会出现
    
29.                         If Right(SheetName, 1) = "$" Then
    
30.                             SQL = "Select * From [" & SheetName & "] "
    
31.                             .Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Cnn.Execute(SQL)
    
32.                         End If
    
33.                     End If
    
34.                     Rs.MoveNext
    
35.                 Loop
    
36.             End If
    
37.         Next
    
38.         For x = 0 To Cnn.Execute(SQL).Fields.Count - 1    '填写标题
    
39.             .Cells(1, x + 1) = Cnn.Execute(SQL).Fields(x).Name
    
40.         Next
    
41.     End With
    
42.     Set Folder = Nothing: Set Fso = Nothing
    
43.     Rs.Close: Cnn.Close
    
44.     Set Rs = Nothing: Set Cnn = Nothing
    
45. End Sub

复制代码

1. Sub GetFiles(ByVal Folder As Object, ArrFile$(), mf&)
   
2.     Dim SubFolder As Object
   
3.     Dim File As Object
   
4.     'If Folder.Path <> ThisWorkbook.Path Then'子文件夹
   
5.     For Each File In Folder.Files
   
6.         If File.Name Like "*.xls*" And InStr(File.Name, ThisWorkbook.Name) = 0 Then
   
7.             mf = mf + 1
   
8.             ReDim Preserve ArrFile(1 To mf)
   
9.             ArrFile(mf) = File
   
10.         End If
    
11.     Next
    
12.     'End If
    
13.     For Each SubFolder In Folder.SubFolders
    
14.         Call GetFiles(SubFolder, ArrFile, mf)
    
15.     Next
    
16. End Sub

复制代码

autumnalRain

第三类例子（之二）：非SQL方法，与SQL方法相同之处都采用递归方法遍历文件

1. Public d
   
2. Sub 按钮1_Click()
   
3.     Application.ScreenUpdating = False
   
4.     ActiveSheet.UsedRange.ClearContents
   
5.     Cells(1, 1) = "编号"
   
6.     Cells(1, 2) = "数量"
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
   
9.     Application.ScreenUpdating = True
   
10.     If d.Count > 0 Then
    
11.         ThisWorkbook.Sheets(1).[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    
12.         ThisWorkbook.Sheets(1).[b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
    
13.     End If
    
14. End Sub
    
15. Sub Getfd(ByVal pth)
    
16.     Set Fso = CreateObject("scripting.filesystemobject")
    
17.     Set ff = Fso.getfolder(pth)
    
18.     For Each f In ff.Files
    
19.         Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理
    
20.         If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then
    
21.             If f.Name <> ThisWorkbook.Name Then
    
22.                 Set wb = Workbooks.Open(f)
    
23.                 For Each sht In wb.Sheets
    
24.                     If WorksheetFunction.CountA(sht.UsedRange) > 1 Then
    
25.                         arr = sht.UsedRange
    
26.                         For j = 2 To UBound(arr)
    
27.                             d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
    
28.                         Next j
    
29.                     End If
    
30.                 Next sht
    
31.                 wb.Close False
    
32.             End If
    
33.         End If
    
34.     Next f
    
35.     For Each fd In ff.subfolders
    
36.         Getfd (fd)    ‘此处与fd.Path效果一样，弄清楚path是不是默认属性可以省略？
    
37.     Next fd
    
38. End Sub

复制代码

xinlan6

好东西！辛苦了autumnalRain老师！赞一个！

LMY123

合并成一薄一表，同薄多表，单夹多薄，多级多夹多薄，ADO法，常规法，已入代码宝库。

DDBB2008

感谢分享，学习了