【83期】VBA多工作簿多工作表数据查询[已小结]

li2t

要找活雷峰，我想应在咱论坛评。

fly8699

进来仰慕下。。

gmshe

活雷峰，就在咱论坛里。

笨笨哥哥1

收藏中，以后看看，学习…！！！！

sl79818

太好了，好好学习一番

sl79818

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

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

zhaogang1960

搜索一下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
    
37. 
    

复制代码

草千里

做个标记，代码真的很棒，收藏之！谢谢

ahhfdw

这个很好！多表快速汇总用的人太多了，但大多都像我辈不太懂vba，所以需要傻瓜式的带选项的多表汇总.各位前辈及版主辛苦了!向你们致敬！！

ahhfdw

zhaogang1960 发表于 2012-4-25 22:20
搜索一下SQL或ADO，学习一下SQL语句的基本知识，否则即使注释了也不好理解：

赵刚版主确实是活雷锋啊！
建议版主：能否把条件改为可选项？这样好拓展，以利于菜鸟们直接使用呢？谢谢！！！