求助：动态提取数据（顺序不管）

zuoxingfa

这是在论坛http://club.excelhome.net/thread-1474630-1-1.html里5楼xiangbaoan老师的回复修改的代码。我想要的要求是：通过横向条件和纵向姓名在当前文件夹下不同的工作簿和工作表中提取对应的数值。
这是我自己修改的代码，但是按F8一步一步的运行，当打开一个工作簿后最小化，可以提取数据，但只能提取工作表1的数据。按F5直接运行就不能提取。希望各位高手老师指点指点（帮忙重写或者修改代码都可以）。谢谢！

蓝桥玄霜

1. Sub 汇总()
   
2. 
   
3.    Dim Wbk As Workbook, Fn$, MyPath$, cnn, k&, Sht As Worksheet
   
4.    Dim s, t$, Sql$
   
5.    Set Sht = Sheet1
   
6.    Sht.Activate
   
7.    MyPath = ThisWorkbook.Path & ""
   
8.    Fn = Dir(MyPath & "*.xl*")
   
9.    Application.ScreenUpdating = False
   
10.    s = "[" & Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose([B7:U7])), "],[") & "]"
    
11.    [B8:U65536] = ""
    
12.    Do While Fn <> ""
    
13.        If Fn <> ThisWorkbook.Name Then
    
14.           Set Wbk = Workbooks.Open(MyPath & Fn)
    
15.           With Wbk
    
16.                With .Sheets("sheet1")
    
17.                     Application.WindowState = xlMinimized
    
18.                     For k = 8 To Sht.Range("a65536").End(xlUp).Row
    
19.                         t = Sht.Range("a" & k).Value
    
20.                         If Len(t) Then
    
21.                             Set cnn = CreateObject("ADODB.Connection")
    
22.                                 cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source=" & MyPath & Fn
    
23.                                 Sql = "SELECT " & s & " FROM [$a2:x] WHERE 姓名 ='" & t & "'"
    
24.                                 Sht.Range("b65536").End(xlUp)(2).CopyFromRecordset cnn.Execute(Sql)
    
25.                                 cnn.Close
    
26.                             Set cnn = Nothing
    
27.                         Else
    
28.                              MsgBox "无提取人！", 64
    
29.                         End If
    
30.                     Next
    
31. 
    
32.                 End With
    
33.                 Application.DisplayAlerts = False
    
34.                 .Close False
    
35.                 Application.DisplayAlerts = True
    
36.             End With
    
37.         End If
    
38.         Fn = Dir
    
39.   Loop
    
40.    Application.ScreenUpdating = True
    
41. End Sub
    
42. 
    

复制代码

芐雨

附件请测试

测试.zip (47.27 KB, 下载次数: 6)

2020-1-9 11:04 上传

点击文件名下载附件

芐雨

1. Sub t()
   
2.     Dim i&
   
3.     Dim cnn, rs, arr
   
4.     Dim myPath$, myFile$
   
5.     Dim sField$, sCdn$
   
6.     Application.ScreenUpdating = False
   
7.     myPath = ThisWorkbook.Path & ""
   
8.     myFile = Dir(myPath & "*.xls*")
   
9.    
   
10.     Range("B8:U" & Rows.Count).Clear
    
11.     arr = [B7:U7]
    
12.     For i = 1 To UBound(arr, 2)
    
13.         sField = IIf(sField = "", "[", sField & ",[") & arr(1, i) & "]"
    
14.     Next
    
15.    
    
16.     arr = Range("A7:A" & Cells(Rows.Count, 1).End(3).Row)
    
17.    
    
18.     For i = 2 To UBound(arr)
    
19.         sCdn = IIf(sCdn = "", Chr(34), sCdn & "," & Chr(34)) & arr(i, 1) & Chr(34)
    
20.     Next
    
21.    
    
22.     Set cnn = CreateObject("adodb.connection")
    
23.     Set rs = CreateObject("adodb.Recordset")
    
24.    
    
25.     Do While myFile <> ""
    
26.         If myFile <> ThisWorkbook.Name Then
    
27.             
    
28.             If Application.Version < 12 Then
    
29.                 cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & myPath & myFile
    
30.             Else
    
31.                 cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & myPath & myFile
    
32.             End If
    
33.             
    
34.             Set rs = cnn.OpenSchema(20) 'adSchemaTables
    
35.             
    
36.             Do Until rs.EOF
    
37.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
38.                     shtName = rs("TABLE_NAME").Value
    
39.                     
    
40.                     Sql = "SELECT " & sField & " FROM [" & shtName & "a2:x] where [姓名] in ( " & sCdn & ")"
    
41.                     
    
42.                     On Error Resume Next
    
43.                     Cells(Rows.Count, 2).End(3).Offset(1).CopyFromRecordset cnn.Execute(Sql)
    
44.                     On Error GoTo 0
    
45.                     
    
46.                 End If
    
47.                 rs.MoveNext
    
48.             Loop
    
49.             cnn.Close
    
50.         End If
    
51.         myFile = Dir
    
52.     Loop
    
53.    
    
54.     Set rs = Nothing
    
55.     Set cnn = Nothing
    
56.    
    
57.         Application.ScreenUpdating = True
    
58. End Sub
    

复制代码

zuoxingfa

蓝桥玄霜 发表于 2020-1-9 09:11

蓝桥老师请您增加两个条件：1、加一个工作表的循环。
2、在V列和W列加上工作簿名和工作表名，最好用偏移，如果b7：u7条件减少，工作簿名和工作表名两列向前移动。
谢谢！

zuoxingfa

芐雨 发表于 2020-1-9 11:04
附件请测试

老师请您增加一个条件：1、在V列和W列加上工作簿名和工作表名，最好用偏移，如果b7：u7条件减少，工作簿名和工作表名两列向前移动。
谢谢！