设为首页收藏本站|繁體中文

Excel 技巧网

 找回密码
 注册

QQ登录

只需一步,快速开始

手机号码,快捷登录

查看: 57641|回复: 103

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

  [复制链接]
发表于 2009-2-5 11:41:02 | 显示全部楼层 |阅读模式
  • 署名作者: gvntw
  • 版权声明: 版权归本站与作者共有 除本站官方外非作者本人转载须经许可并注明出处
  • 本文来自:
  • 引用作品:
  • 适用版本: 2010 2007 2003以前版本 
  • 语言环境: 简体中文
  • 学习方法: 掌握Excel技巧的关键是动手操作 | 下载 ≠ 知识


  • 免费注册成为本站会员,享用更多功能,结识更多Office办公高手!

    您需要 登录 才可以下载或查看,没有帐号?注册

    x
    把文件所在的文件夹内所有工作簿的所有工作表中姓王的记录汇总到一个工作表,代码如下:

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

    合并.zip

    44.58 KB, 下载次数: 1326, 下载积分: 消费券 -5 Ti币

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

    评分

    参与人数 3魅力值 +15 收起 理由
    LOGO + 5 技法娴熟:)
    xiongkehua2008 + 5 這個收錄了,好東西...
    无心为爱 + 5 精品文章:)

    查看全部评分

    发表于 2009-2-5 13:33:55 | 显示全部楼层
    学习了 通过Catalog 的Tables集合来获取表名信息很好!除了对小段代码的用途加了注释外,作为文章,如果能对关键语句的作用再加以解释就更好了。
    回复 支持 反对

    使用道具 举报

     楼主| 发表于 2009-2-5 14:50:49 | 显示全部楼层
    已在 1 楼对每一句添加注释。

    评分

    参与人数 1魅力值 +5 收起 理由
    apolloh + 5 感谢帮助:)

    查看全部评分

    回复 支持 反对

    使用道具 举报

    发表于 2009-2-11 22:49:26 | 显示全部楼层
    真不错哦,呵呵,学习一下
    回复 支持 反对

    使用道具 举报

    发表于 2009-5-13 09:49:34 | 显示全部楼层
    不错不错,感谢分享,对每一句添加了说明,方便阅读!
    回复 支持 反对

    使用道具 举报

    发表于 2009-5-27 15:56:18 | 显示全部楼层
    谢谢了
    回复 支持 反对

    使用道具 举报

    发表于 2009-6-2 12:06:54 | 显示全部楼层
    Thanks a lot.
    回复 支持 反对

    使用道具 举报

    发表于 2009-6-9 00:46:27 | 显示全部楼层
    华山论剑~~~~
    回复 支持 反对

    使用道具 举报

    发表于 2009-7-16 12:07:41 | 显示全部楼层
    好,没试过
    回复 支持 反对

    使用道具 举报

    发表于 2009-7-23 21:09:47 | 显示全部楼层
    真是不错,谢谢分享,学习了。

    评分

    参与人数 1魅力值 +3 收起 理由
    womobo + 3 楼主辛苦了

    查看全部评分

    回复 支持 反对

    使用道具 举报

    您需要登录后才可以回帖 登录 | 注册

    本版积分规则

    关闭

    站长推荐上一条 /1 下一条

    Excel技巧网的会员探讨问题仅代表其个人意见,与网站的立场无关。任何违反国家和地方相关法律法规的言论,本站有义务协助政府相关部门追究发言者的责任!
    本站中非注明转载文章与案例的版权为作者与Excel技巧网共有。若非原文作者,本站之外任何单位或个人未经允许,不得将其用于商业用途。
    若非原文作者,任何形式的非商业性转载必须获得Excel技巧网或作者允许,并注明作者和出处。
    会员发表的帖子如涉及版权纠纷,须自行负责。详情请参考注册时的网站服务条款。
    本站特聘法律顾问:沈学律师

    Archiver|手机版|Excel技巧网 ( 闽ICP备08107682号-2 ) | 闽公网安备 35020302032608号  

    GMT+8, 2018-1-20 10:58

    Powered by Discuz! X3.3

    © 2001-2017 Comsenz Inc.

    快速回复 返回顶部 返回列表