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

gufengaoyue

{:soso_e195:}

panan123_0

我也交个试试,循环的优点绕。还望海涵。初学者。

zm0115

好不容易做出来。但速度还是不行

zhangjimfu

1. 
   
2. Sub WorkbooksSheetsTotalADO()
   
3. 
   
4.     Dim rst, rst2, cnn, sql, myPath$, myFile$, sRow As Single
   
5.     myPath = ThisWorkbook.Path & ""
   
6.     myFile = Dir(myPath & "*.xls")
   
7.     Set rst = CreateObject("ADODB.Recordset")
   
8.     Set cnn = CreateObject("ADODB.Connection")
   
9.     Application.ScreenUpdating = False
   
10.    
    
11.     Range("a4:h600").ClearContents
    
12.     While myFile <> ""
    
13.         sRow = WorksheetFunction.CountA(Range("a1:a65536")) + 2
    
14.         If myFile <> ThisWorkbook.Name Then
    
15.             sql = "Select 序号,姓名,客户号,合同号,档案编号,期限,'" & Left(myFile, 6) & "' as 所在档案,部门" & _
    
16.                   " From(Select *,""部门1"" as 部门 From[1部门$A3:G100]" & _
    
17.                   " Union Select *,""部门2"" as 部门 From[2部门$A3:G100]" & _
    
18.                   " Union Select *,""部门3"" as 部门 From[3部门$A3:G100])" & _
    
19.                   " Where 姓名='" & Cells(2, 3) & "'"
    
20.             cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & _
    
21.                      myPath & myFile
    
22.             Set rst = cnn.Execute(sql)
    
23.             Range("a" & sRow).CopyFromRecordset rst
    
24.             cnn.Close
    
25. 
    
26.         End If
    
27.         myFile = Dir
    
28.     Wend
    
29.    
    
30.     Set rst = Nothing
    
31.     Set cnn = Nothing
    
32.     Application.ScreenUpdating = False
    
33.    
    
34. End Sub
    

复制代码

岁寒三友

跟着赵老师学习了。

hzhb14796

用比较的方法，程序运行很慢，
考虑到一个档案里一个部门重名的可能性太低，可以用FIND 方法，但感觉不出那个更快，干脆都发上

minjiwei

请指正，谢谢。

zhaogang1960

截至日期已到，谢谢各位参与答题，已测试各位代码，现将各位得分情况公布如下：

zhaogang1960

小结：

本题主要测试ADO实现多工作簿多表（超过49个）联合查询，本来有速度要求，在冻版主建议下取消了要求，只要结果正确就可以得分
为了减小难度，加了80个工作簿和“每个工作簿都有3个格式相同的工作表，名称分别是1部门、2部门和3部门”的条件
下面给出3个参考da'an（系统不准出现这两个字，歉），其中第一个不使用上面给出的条件，请广大会员斧正：


[code=vb]Sub Macro1() '通用，不使用条件：已知“每个工作簿都有3个格式相同的工作表，名称分别是1部门、2部门和3部门”
tt = Timer
    Dim cnn As Object, cat As Object, d As Object
    Dim SQL$, MyFile$, arr(), i&, j&, t$, s$, wk$, m&, n&
    temp = [c2]
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(3).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Set cnn = CreateObject("adodb.connection")
    Set cat = CreateObject("ADOX.Catalog")
    Set d = CreateObject("scripting.dictionary")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            wk = Replace(MyFile, ".xls", "")
            n = n + 1
            If n = 1 Then cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
            cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=No';Data Source=" & MyPath & MyFile
            For Each tb1 In cat.Tables
                If tb1.Type = "TABLE" Then
                    s = Replace(tb1.Name, "'", "")
                    If Right(s, 1) = "$" Then
                        m = m + 1
                        SQL = "select 序号,姓名,客户号,合同号,档案编号,期限,'" & wk & "','" & Replace(s, "$", "") & "' from [Excel 8.0;Database=" & MyPath & MyFile & "].[" & s & "a3:f65536] where 姓名='" & temp & "'"
                        d(SQL) = ""
                        If m Mod 49 = 0 Then
                            SQL = Join(d.Keys, " UNION ALL ")
                            [a65536].End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                            d.RemoveAll
                        End If
                    End If
                End If
            Next
        End If
        MyFile = Dir()
    Loop
    If d.Count > 0 Then
        SQL = Join(d.Keys, " UNION ALL ")
        [a65536].End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    End If
    Set cat = Nothing
    Set tb1 = Nothing
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - tt
End Sub
[/code]
[code=vb]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
[/code]
[code=vb]Sub Macro3() '简易，速度较快，只适用已知“每个工作簿都有3个格式相同的工作表，名称分别是1部门、2部门和3部门”
tt = Timer
    Dim cnn As Object
    Dim SQL$, MyPath$, MyFile$, wk$, a, i%, t$, m%, n%
    t = [c2]
    a = Array("1部门", "2部门", "3部门")
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(3).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyFile = Dir(MyPath & "*.xls")
    Set cnn = CreateObject("adodb.connection")
    Do While MyFile <> ""
        If MyFile <> ThisWorkbook.Name Then
            n = n + 1
            If n = 1 Then cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
            wk = Replace(MyFile, ".xls", "")
            For i = 0 To 2
                m = m + 1
                If m > 49 Then
                    [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                    m = 1
                    SQL = ""
                End If
                If Len(SQL) Then SQL = SQL & " union all "
                SQL = SQL & "select 序号,姓名,客户号,合同号,档案编号,期限,'" & wk & "','" & a(i) & "' from [Excel 8.0;Database=" & MyPath & MyFile & "].[" & a(i) & "$a3:f65536] where 姓名='" & t & "'"
            Next
        End If
        MyFile = Dir()
    Loop
    If Len(SQL) Then [a65536].End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - tt
End Sub

[/code]

onthetrip2008

我还不懂什么是连接自身,请版主有空解释一下,谢谢先
------------------------
刚看了赵老师的代码,明白了,是不是data source后面是thisworkbook就视作在连接自身?
------------------------
哇哇哇,来论坛学习两年半了,终于有了神往已久的技术分,幸福啊.晚上请人喝酒去,庆祝一下今天这个好日子,呵呵......
谢谢赵老师.