ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
楼主: zhaogang1960

[Excel 程序开发] 【83期】VBA多工作簿多工作表数据查询[已小结]

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2012-3-2 13:18 | 显示全部楼层
本帖已被收录到知识树中,索引项:工作表和工作簿
要找活雷峰,我想应在咱论坛评。

TA的精华主题

TA的得分主题

发表于 2012-3-8 23:49 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-3-13 16:11 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-3-23 03:41 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-4-25 20:42 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-4-25 21:43 | 显示全部楼层
Sub Macro2() '简易,速度较快,只适用已知“每个工作簿都有3个格式相同的工作表,名称分别是1部门、2部门和3部门”
tt = Timer
    Dim cnn As Object
    Dim SQL$, MyPath$, MyFile$, a, arr(), i%, ii%, j%, t$, m%
    t = [c2]
    a = Array("1部门$a3:f65536", "2部门$a3:f65536", "3部门$a3:f65536")
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(3).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            m = m + 1
            ReDim Preserve arr(1 To m)
            arr(m) = MyFile
        End If
        MyFile = Dir()
    Loop
    Set cnn = CreateObject("adodb.connection")
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & arr(1)
    For i = 1 To m Step 16
        SQL = ""
        For ii = i To i + 15
            If ii > m Then Exit For
            For j = 0 To 2
                If Len(SQL) Then SQL = SQL & " union all "
                SQL = SQL & "select 序号,姓名,客户号,合同号,档案编号,期限,'" & Replace(arr(ii), ".xls", "") & "','" & Left(a(j), 3) & "' from [Excel 8.0;Database=" & MyPath & arr(ii) & "].[" & a(j) & "] where 姓名='" & t & "'"
            Next
        Next
        [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    Next
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - tt
End Sub

这都什么意思呀?版主能否给注释一下?让菜鸟也学习一下

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-4-25 22:20 | 显示全部楼层
搜索一下SQL或ADO,学习一下SQL语句的基本知识,否则即使注释了也不好理解:
  1. Sub Macro2() '简易,速度较快,只适用已知“每个工作簿都有3个格式相同的工作表,名称分别是1部门、2部门和3部门”
  2. tt = Timer
  3.      Dim cnn As Object
  4.      Dim SQL$, MyPath$, MyFile$, a, arr(), i%, ii%, j%, t$, m%
  5.      t = [c2] '要查询的姓名
  6.      a = Array("1部门$a3:f65536", "2部门$a3:f65536", "3部门$a3:f65536") '3个工作表的数据区
  7.      Application.ScreenUpdating = False '关闭屏幕刷新
  8.      ActiveSheet.UsedRange.Offset(3).ClearContents '清除原数据
  9.      MyPath = ThisWorkbook.Path & "" '路径
  10.      MyFile = Dir(MyPath & "*.xls") '利用dir函数查找.xls文件
  11.      Do While MyFile <> "" '查到文件
  12.          If MyFile <> ThisWorkbook.Name Then '不是本工作簿
  13.              m = m + 1 '计数
  14.              ReDim Preserve arr(1 To m) '重新定义动态数组
  15.              arr(m) = MyFile '数组储存文件名
  16.          End If
  17.          MyFile = Dir() '继续调用dir函数查找
  18.      Loop '循环
  19.      Set cnn = CreateObject("adodb.connection") '创建connection对象
  20.      cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & arr(1) '连接第一个工作簿
  21.      For i = 1 To m Step 16 '逐个文件,16个文件为一组(48个工作表,不超过ADO最大联合查询49个工作表的限制)
  22.          SQL = "" '设置SQL语句初值(48个工作表使用一个SQL语句)
  23.          For ii = i To i + 15 '16个文件为一组
  24.              If ii > m Then Exit For '如果文件数超过实际文件数m则退出循环
  25.              For j = 0 To 2 '逐个工作簿
  26.                  If Len(SQL) Then SQL = SQL & " union all " '使用union all把每个工作表的SQL语句连起来
  27.                  SQL = SQL & "select 序号,姓名,客户号,合同号,档案编号,期限,'" & Replace(arr(ii), ".xls", "") & "','" & Left(a(j), 3) & "' from [Excel 8.0;Database=" & MyPath & arr(ii) & "].[" & a(j) & "] where 姓名='" & t & "'"
  28.              Next
  29.          Next
  30.          [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL) '48个工作表复制一次查询数据
  31.      Next
  32.      cnn.Close '关闭connection连接
  33.      Set cnn = Nothing '释放内存
  34.      Application.ScreenUpdating = True '启动屏幕刷新
  35.      MsgBox Timer - tt
  36. End Sub

复制代码

TA的精华主题

TA的得分主题

发表于 2012-5-14 17:13 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-6-4 11:05 | 显示全部楼层
这个很好!多表快速汇总用的人太多了,但大多都像我辈不太懂vba,所以需要傻瓜式的带选项的多表汇总.各位前辈及版主辛苦了!向你们致敬!!

TA的精华主题

TA的得分主题

发表于 2012-6-4 11:15 | 显示全部楼层
本帖最后由 ahhfdw 于 2012-6-4 11:24 编辑
zhaogang1960 发表于 2012-4-25 22:20
搜索一下SQL或ADO,学习一下SQL语句的基本知识,否则即使注释了也不好理解:


赵刚版主确实是活雷锋啊!
建议版主:能否把条件改为可选项?这样好拓展,以利于菜鸟们直接使用呢?谢谢!!!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-3-24 21:36 , Processed in 0.078964 second(s), 9 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

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