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

zhaogang1960

1.答题前请先阅读最新规则:正式竞赛区运行规则说明
2.可跟贴直接发答案、上传答案附件

题目说明及答题要求:
本题目为实际应用题，不需要深奥的理论，题目如下：
有80个格式相同的工作簿，每个工作簿都有3个格式相同的工作表，名称分别是1部门、2部门和3部门，每个工作表都有很多记录，要求输入姓名，快速查询出该姓名所有记录及所在工作簿和工作表名，方法不限，如果使用ADO查询，不能连接自身，复制数据次数不超过5次，数组法和ADO法不得混用，答案正确且方法符合要求者可得分，用时少者可以另行加分。

评分：
1.总分2分。
2.精彩答案另加分。

截至日期：2011－11－21前
附件：

效果演示：


该贴已经同步到 zhaogang1960的微博

AVEL

速度不行。。。
先回复一个，传统的数组法。

AVEL

更新个SQL版本的。
不知道跟赵老师的答案是否相符哈。。速度还是可以的。

wcymiss

不知对不对，请老师指点：

xmyjk

分析题目已知条件：（1）工作表数量已知：80个；
（2）格式已知：每个工作簿都有3个格式相同的工作表，名称分别是1部门、2部门和3部门

经上分析，不需在用ADO植入连接或者打开表获取表名，直接用ADO查询获取数据且不打开表可加快效率，不过没记错的话，ADO+SQL中，UNION ALL最多支持连接49个表。那就没16个工作薄做一次ADO连接吧。
程序如下：

1. Option Explicit
   
2. Sub 按钮2_Click()
   
3.     Dim d, j&, cn, T As Double, sql$, MyPath$, MyFiles$, TWb$, bm$, m&, nm&
   
4. 
   
5.     Application.ScreenUpdating = False
   
6.     T = Timer
   
7.     Range([A4], [H65536].End(3).Offset(1)).Clear
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     Set cn = CreateObject("ADODB.Connection")
   
10.     TWb = ThisWorkbook.Name
    
11.     MyPath = ThisWorkbook.Path
    
12.     MyFiles = Dir(MyPath & "\*.xls")
    
13. 
    
14.     Do While MyFiles <> ""
    
15.         If TWb <> MyFiles Then
    
16.             m = m + 1
    
17.             bm = Replace(MyFiles, ".xls", "")
    
18.             For j = 1 To 3
    
19.                 sql = "Select """ & bm & """ ,""" & j & "部门"" ,* From [excel 8.0;HDR=NO;DATABASE=" & MyPath & "" & MyFiles & "].[" & j & "部门$]"
    
20.                 d(sql) = ""
    
21.             Next
    
22.             If m Mod 16 = 0 Then
    
23.                 sql = Join(d.Keys, " UNION ALL ")
    
24.                 sql = "SELECT F1,F2,F3,F4,F5,F6,EXPR1000,EXPR1001 from (" & sql & ") WHERE F2 = '" & Cells(2, 3).Value & "'"
    
25.                 sql = Replace(sql, "[excel 8.0;HDR=NO;DATABASE=" & MyPath & "" & MyFiles & "].", "")
    
26.                 cn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data source=" & MyPath & "" & MyFiles
    
27.                 [a65536].End(3).Offset(1).CopyFromRecordset cn.Execute(sql)
    
28.                 cn.Close
    
29.                 d.RemoveAll
    
30.                 nm = nm + 1
    
31.             End If
    
32.         End If
    
33.         MyFiles = Dir
    
34.     Loop
    
35. 
    
36.     Set cn = Nothing: Set d = Nothing
    
37.     Application.ScreenUpdating = True
    
38.     MsgBox "取数" & nm & "次;耗时" & Timer - T & "秒"
    
39. End Sub
    

复制代码

oyzhjr

算法不是太难。

代码如下：

Option Explicit
Const QSH As Integer = 3        '定义每个工作表数据的起始行
Const SHT_COUNT As Integer = 3      '定义每个档案中工作表的个数
Rem ++++++++++++++++++++定义档案类型+++++++++++++++++++++++
Private Type type_da
    xuHao As Integer
    xingMing As String
    keHuHao As String
    heTongHao As String
    danAnBianHao As String
    qiXian As Date
    suoZaiDangan As String
    buMen As String
End Type
Dim DA(1500) As type_da                 '定义档案类型数组
Dim ct_rec As Integer                       '定义记录个数
Dim find_name As String                   '定义要查找人员的名字

Private Sub CommandButton1_Click()
Rem         '获取当前工作表下的所有文件并判断

Dim me_Path As String                    '定义当前文件所在的目录
Dim FSO                                           '定义文件对象
Dim files                                            '定义文件集合
Dim xfile                                           '定义文件

find_name = ThisWorkbook.Sheets(1).Cells(2, 3).Value
If find_name = "" Then
    MsgBox "请输入要查找人员的姓名", vbOKOnly + vbExclamation, "注意"
    Exit Sub
End If
Application.ScreenUpdating = False
ct_rec = 0                  '必须重设为0，否则连续查找时会出错
Set FSO = CreateObject("Scripting.FileSystemObject")
me_Path = ThisWorkbook.Path
For Each xfile In FSO.GetFolder(me_Path).files
    If xfile.Name Like "###号档案.xls" Then READ_DANGAN (me_Path & "\" & xfile.Name)        '当文件名符合档案文件名时，从其中读取数据
Next

PASTE_DATA
Application.ScreenUpdating = True
MsgBox "已经完成了档案的搜索" & vbCrLf & "共找到 " & ct_rec & " 条符合要求的档案 。", vbOKOnly + vbInformation, "注意"

End Sub

Private Sub READ_DANGAN(ByVal wjm As String)
Rem                 打开文件并读取其中符合条件的数写入到数组中
Rem                 关闭屏幕刷新，提高运行速度

Dim xbook As Workbook
Dim xsheet As Worksheet

Dim rnga As Range
Dim js_a As Integer
Dim js_b As Integer
Dim js_c As Integer

Set xbook = Workbooks.Open(wjm)
For js_a = 1 To SHT_COUNT
    Set xsheet = xbook.Sheets(js_a)
    With xsheet
        .Activate
        .Cells(QSH, 1).Select
        .Range(Selection, Selection.End(xlToRight)).Select
        .Range(Selection, Selection.End(xlDown)).Select
        Set rnga = Selection
        js_b = QSH + rnga.Rows.Count
        js_c = QSH + 1
        
        Do While js_c < js_b
            If .Cells(js_c, 2).Value = find_name Then
                DA(ct_rec).xuHao = .Cells(js_c, 1).Value
                DA(ct_rec).xingMing = find_name               '使用查询的名字，更快捷一些
                DA(ct_rec).keHuHao = .Cells(js_c, 3).Value
                DA(ct_rec).heTongHao = .Cells(js_c, 4).Value
                DA(ct_rec).danAnBianHao = .Cells(js_c, 5).Value
                DA(ct_rec).qiXian = .Cells(js_c, 6).Value
                DA(ct_rec).suoZaiDangan = Left(xbook.Name, InStr(UCase(xbook.Name), ".XLS") - 1)        '获取所在工作表中的名字中扩展名以外的部分
                DA(ct_rec).buMen = xsheet.Name
                ct_rec = ct_rec + 1
            End If
            js_c = js_c + 1
        Loop
    End With
Next
xbook.Close False
End Sub
Private Sub PASTE_DATA()
Rem    将数据粘贴到对应本工作表中对应的区域
Dim js_a As Integer
Dim js_b As Integer
   
With ThisWorkbook.ActiveSheet
    .Rows("4:1500").Delete
    .Range("C:D").NumberFormatLocal = "@"                       '设定文字格式，避免科学计数
    .Range("F:F").NumberFormatLocal = "yyyy-m-d"
    js_a = ct_rec + 4 - 1
    For js_b = 4 To js_a
        .Cells(js_b, 1).Value = DA(js_b - 4).xuHao
        .Cells(js_b, 2).Value = find_name
        .Cells(js_b, 3).Value = DA(js_b - 4).keHuHao
        .Cells(js_b, 4).Value = DA(js_b - 4).heTongHao
        .Cells(js_b, 5).Value = DA(js_b - 4).danAnBianHao
        .Cells(js_b, 6).Value = DA(js_b - 4).qiXian
        .Cells(js_b, 7).Value = DA(js_b - 4).suoZaiDangan
        .Cells(js_b, 8).Value = DA(js_b - 4).buMen
    Next
End With
   
End Sub

huangwei0king

1. 
   
2. Sub 记录查询()
   
3.     Dim cent, s, i, j, p, n, m, pp
   
4.     Dim pt As String
   
5.     Dim t, fnanme
   
6.     Dim arr
   
7.     Dim brr() As String
   
8.     Application.ScreenUpdating = False
   
9.     On Error Resume Next
   
10.     pt = ThisWorkbook.Path
    
11.     Set cent = CreateObject("Scripting.FileSystemObject")
    
12.     Set s = cent.GetFolder(pt)
    
13.     t = ThisWorkbook.Sheets(1).Range("c2")
    
14.     For Each i In s.Files
    
15.         If i <> ThisWorkbook.FullName Then
    
16.             Workbooks.Open Filename:=i
    
17.             fname = Left(Workbooks(2).Name, 6)
    
18.             For j = 1 To 3
    
19.                 p = Workbooks(2).Sheets(j).Range("a65536").End(xlUp).Row
    
20.                 arr = Workbooks(2).Sheets(j).Range("a4:f" & p)
    
21.                 For n = 1 To UBound(arr)
    
22.                     If arr(n, 2) = t Then
    
23.                         m = m + 1
    
24.                         ReDim Preserve brr(1 To 8, 1 To m)
    
25.                         brr(1, m) = arr(n, 1)
    
26.                         brr(2, m) = arr(n, 2)
    
27.                         brr(3, m) = arr(n, 3)
    
28.                         brr(4, m) = arr(n, 4)
    
29.                         brr(5, m) = arr(n, 5)
    
30.                         brr(6, m) = arr(n, 6)
    
31.                         brr(7, m) = fname
    
32.                         brr(8, m) = Workbooks(2).Sheets(j).Name
    
33.                     End If
    
34.                 Next
    
35.                 Erase arr
    
36.             Next
    
37.             Workbooks(2).Close SaveChanges:=False
    
38.         End If
    
39.     Next
    
40.     pp = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
    
41.     If pp > 3 Then
    
42.         ThisWorkbook.Sheets(1).Range("a4:h" & pp).ClearContents
    
43.     End If
    
44.     ThisWorkbook.Sheets(1).Range("a4").Resize(UBound(brr, 2), 8) = Application.Transpose(brr)
    
45.     Erase brr
    
46.     Application.ScreenUpdating = True
    
47. End Sub
    
48. 附件传不上来，太大了，400多K!

复制代码

onthetrip2008

虽然做出来来了,但代码笨拙,很多内在的原理还没搞明白

chunlin1wang

1. 
   
2. Sub myzc()
   
3.     Dim MyFile As Object
   
4.     Dim MyApp As New Application
   
5.     Dim Sh As Worksheet, rng As Range
   
6.     Dim Temp As String, Mydir As String, Mymc As String
   
7.     Dim i As Integer, n As Integer
   
8.     n = 4
   
9.         MyApp.Visible = False
   
10.         Range("A4:H65536").ClearContents
    
11.         Mydir = Dir(ThisWorkbook.Path & "\*.xls", vbNormal)
    
12.         Do While Mydir <> ""
    
13.             If Mydir <> "&para;à&sup1;¤×÷&sup2;&frac34;&para;à&sup1;¤×÷±í&Ecirc;&yacute;&frac34;&Yacute;&sup2;é&Ntilde;&macr;.xls" Then
    
14.                 Set MyFile = CreateObject("Scripting.FileSystemObject")
    
15.                 Mymc = MyFile.GetBaseName(Mydir)
    
16.                 Temp = ThisWorkbook.Path & "" & Mydir
    
17.                 For i = 1 To 3
    
18.                     Set Sh = MyApp.Workbooks.Open(Temp).Sheets(i & "&sup2;&iquest;&Atilde;&Aring;")
    
19.                         For k = 4 To Sh.Range("A65536").End(xlUp).Row
    
20.                             If Sh.Range("B" & k) = Range("C2").Value Then
    
21.                                 For l = 1 To 6
    
22.                                     Cells(n, l) = Sh.Cells(k, l)
    
23.                                 Next l
    
24.                                 Cells(n, 7) = Mymc
    
25.                                 Cells(n, 8) = i & "&sup2;&iquest;&Atilde;&Aring;"
    
26.                                 n = n + 1
    
27.                             End If
    
28.                         Next k
    
29.                 Next i
    
30.                 MyApp.Quit
    
31.                 Set MyFile = Nothing
    
32.                 Set Sh = Nothing
    
33.             End If
    
34.             Mydir = Dir
    
35.         Loop
    
36.         Set MyApp = Nothing
    
37.   End Sub
    
38. 
    

复制代码

wyf22006

1.   Private Sub CommandButton1_Click()
   
2. Dim myPath$, myFile$, AK As Workbook, k%, i As Integer, ii%
   
3. Dim arr()
   
4.     Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   
5.     myPath = ThisWorkbook.Path & ""          '把文件路径定义给变量
   
6.     ThisWorkbook.Sheets(1).Range("a4").CurrentRegion.Offset(2, 0).Clear
   
7.     myFile = Dir(myPath & "*.xls") '依次找寻指定路径中的*.xls文件
   
8.     Do While myFile <> ""                     '当指定路径中有文件时进行循环
   
9.     If myFile <> ThisWorkbook.Name Then
   
10.     Set AK = Workbooks.Open(myPath & myFile) '打开符合要求的文件
    
11.         For i = 1 To AK.Sheets.Count
    
12.           For ii = 4 To AK.Sheets(i).Range("b65536").End(xlUp).Row
    
13.         With ThisWorkbook.Sheets(1)
    
14.             If AK.Sheets(i).Cells(ii, 2).Value = .Range("c2").Value Then
    
15.             k = k + 1
    
16.                ReDim Preserve arr(1 To 8, 1 To k)
    
17.                arr(1, k) = AK.Sheets(i).Cells(ii, 1)
    
18.                arr(2, k) = AK.Sheets(i).Cells(ii, 2)
    
19.                arr(3, k) = AK.Sheets(i).Cells(ii, 3)
    
20.                arr(4, k) = AK.Sheets(i).Cells(ii, 4)
    
21.                arr(5, k) = AK.Sheets(i).Cells(ii, 5)
    
22.                arr(6, k) = AK.Sheets(i).Cells(ii, 6)
    
23.                arr(7, k) = Left(AK.Name, Len(AK.Name) - 4)
    
24.                arr(8, k) = AK.Sheets(i).Name
    
25.             End If
    
26.             End With
    
27.          Next ii
    
28.     Next i
    
29.     AK.Close False
    
30.     End If
    
31.     myFile = Dir                                   '找寻下一个*.xls文件
    
32.     Loop
    
33.     Range("a4:H" & UBound(arr, 2) + 3) = Application.Transpose(arr)
    
34.     Application.ScreenUpdating = True '冻结屏幕,此类语句一般成对使用
    
35. End Sub
    
36. 
    

复制代码