ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > E文精选 > Excel VBA > 条件汇总文件夹内所有工作簿的所有工作表记录

条件汇总文件夹内所有工作簿的所有工作表记录

作者：绿色风 分类： 时间：2022-08-17 浏览：198
楼主
gvntw		 把文件所在的文件夹内所有工作簿的所有工作表中姓王的记录汇总到一个工作表，代码如下：

  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                                     '结束过程

合并.zip
2楼
apolloh		 学习了 通过Catalog 的Tables集合来获取表名信息很好！除了对小段代码的用途加了注释外，作为文章，如果能对关键语句的作用再加以解释就更好了。
3楼
gvntw		 已在 1 楼对每一句添加注释。
4楼
xxiaoa		 真不错哦，呵呵，学习一下
5楼
ggsmart		 不错不错，感谢分享，对每一句添加了说明，方便阅读！
6楼
jl128		 谢谢了
7楼
goldowl		 Thanks a lot.
8楼
hfyk007		 华山论剑~~~~
9楼
BB开心		 好，没试过
10楼
yukaiwz		 真是不错，谢谢分享，学习了。
11楼
yqneil		 不错不错，
12楼
gzy001		 多谢了，下来学学，辛苦了！！！！！！！！！！！！！！！！！
13楼
sqm1117		 以前用过发哥相类的一个大作，现今再做变化，真当多姿多彩，收藏，谢谢！
14楼
风中的百合		 不知道怎么用。
15楼
hwh6963		 未命名.rar

报错
不知怎么使用
16楼
opcbo		 确实不错，加赞1
17楼
jl128		 好东西，学习
18楼
aob		 看看高手的表演，学习了！
19楼
aob		 看看高手的表演，学习了！
20楼
xiongkehua2008		 這個真是好東西,下載學習了...
21楼
wnianzhong		 这个要好好学一下,用的着!
22楼
kklivtre		 只能说强悍
23楼
PETER		 谢谢!不过这不是财务报表啊.
24楼
wangqilong1980		 收藏慢慢学习。越学习，越发现自已的无知！
25楼
快乐的悲哀		 谢谢分享，慢慢学习
26楼
pingdande		 不错不错，感谢分享，对每一句添加了说明，方便阅读！
27楼
99253415		 偶像，这个厉害收藏了先。
28楼
lisan		 谢谢分享！我是来学习的，留个记号。
29楼
迅岐同心		 发哥，一出招就给人以震撼力！
30楼
zhujunyun		 谢谢楼主
31楼
glhfgtd		 太强了，谢谢楼主
32楼
lisan		 谢谢分享！我是来学习的，留个记号。
33楼
kszcs		 太强了，好好
34楼
renrg68		 谢谢分享！
35楼
kszcs
这个是把表归集在一张表上。如果想把文件夹内的工资表汇总（同类相相加），怎么改代码？
36楼
renrg68		 谢谢分享
37楼
fgaq111		 VBA就晕。哎……
38楼
wswcp		 学习，谢谢分享
39楼
qinhuan66		 好好学习天天向上
40楼
我是我又不是我
啦啦啦，啦啦啦，我是EXCEL的受害者，为了吃为了穿，每天必须忙！

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap