Excel|条件汇总文件夹内所有工作簿的所有工作表符合条件的所有行的数据

合并.zip (44.58 KB, 下载次数: 397)

2015-1-1 22:41 上传

点击文件名下载附件

把文件所在的文件夹内所有工作簿的所有工作表中姓王的记录汇总到一个工作表，代码如下， 针对自己的表格不同，适当修改一下，就可以使用

1. 
   
2. '***************************************************
   
3. '# By gvntw 王建发                                 #
   
4. '# 引用 Microsoft Scripting Runtime                #
   
5. '# 引用 Microsoft ActiveX Data Objects 2.8 Library #
   
6. '# 引用 Microsoft ADO Ext.2.8 For DDL and Security #
   
7. '***************************************************
   
8. Private Sub CommandButton1_Click()
   
9.     Dim d As New Dictionary, arr(), i%, j%  '声明字典、数组、整型变量
   
10.     Dim cn As New ADODB.Connection          'ADO对象
    
11.     Dim rst As New ADODB.Recordset          '记录集对象
    
12.     Dim cat As New Catalog                  'ADOX引用
    
13.     Dim sql$, MyPath$, MyFiles$, TWb$       'String 变量
    
14.    
    
15.     On Error GoTo Err                       '发生错误跳到 Err
    
16.     Cells = Empty                           '清空单元格数据
    
17.     TWb = ThisWorkbook.Name                 '取本工作簿名
    
18.    
    
19.     MyPath = ThisWorkbook.Path              '文件路径
    
20.     MyFiles = Dir(MyPath & "*.xls")         '取文件名
    
21.     Do While MyFiles <> ""                  '循环文件
    
22.         If TWb <> MyFiles Then              '如果不是本工作簿文件名
    
23.             d.Add MyFiles, 0                '把文件名添加到字典对象
    
24.             j = j + 1                       '文件数量计数
    
25.         End If
    
26.         MyFiles = Dir                       '下一个文件
    
27.     Loop                                    '进入下一个循环迭代
    
28.    
    
29.     If j = 0 Then                           '如果文件数量为0，则弹出对话框
    
30.         MsgBox "没有文件可合并", , "gvntw"
    
31.         Exit Sub                            '退出过程
    
32.     End If
    
33.    
    
34.     arr = d.Keys: d.RemoveAll               '把字典里的Keys赋值给数组，移除字典所有键值
    
35.     For i = 0 To UBound(arr)                '循环工作簿
    
36.         cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & "" & arr(i) '打开ADO联接
    
37.         Set cat.ActiveConnection = cn       '设置ADOX引用
    
38.         For Each Tabs In cat.Tables         '循环工作表
    
39.             sql = "Select """ & Replace(arr(i), ".xls", "") & """ as 单位,""" & Replace(Tabs.Name, "$", "") & _
    
40.                            """ as 月份,* From [Excel 8.0;DATABASE=" & MyPath & "" & arr(i) & "].[" & Tabs.Name & "]"  'sql语句
    
41.             d.Add sql, 0                    '添加到字典
    
42.         Next                                '下一个循环迭代
    
43.         cn.Close                            '关闭联接
    
44.     Next                                    '下一循环
    
45.     sql = Join(d.Keys, " UNION ALL ")       '把字典的Keys用“ UNION ALL ”连接赋值给sql
    
46.     sql = "SELECT  * from (" & sql & ") where 姓名 like '王%' order by 姓名,月份"                  
    
47.                                 '只汇总姓王的记录，如果要汇总全部记录，请把“where 姓名 like '王%'”删除，在sql语句中用%作用通配符，而不用*号
    
48.     cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & arr(0)  '打开联接
    
49.     Set rst = cn.Execute(sql)               '记录集
    
50.     For i = 1 To rst.Fields.Count           '循环字段
    
51.         Cells(1, i) = rst(i - 1).Name       '录入字段名
    
52.     Next                                    '下一循环
    
53.    
    
54.     Range("a2").CopyFromRecordset rst       '复制查询结果
    
55.     rst.Close: Set rst = Nothing            '关闭记录集，并在内存中清除
    
56.     cn.Close: Set cn = Nothing: Set d = Nothing        '关闭ADO联接，并在内存中清除ADO和字典对象，释放内存
    
57.     MsgBox "表格已汇总完成", , "gvntw"        '弹出完成对话框
    
58.     Exit Sub                                '退出过程
    
59. Err:                                        '错误跳转程序
    
60. MsgBox Err.Description, , "错误报告"         '弹出错误原因报告
    
61. End Sub                                     '结束过程
    

复制代码