多工作薄多条件查询求助

chengshanming

有以下需求，请高手帮忙啦！
说明：1.每个工作薄中，工作表的个数不确定，可能有空白工作表，工作表的命名也不规律。但有内容的工作表，格式都是一样的。
          2.要求如截图，不打开任何目标工作薄，查询任何一个字段，能查询出所有明细，并且速度较快，适应更多个工作薄（目前2个）的情况。   

wangnb819

你这个其实是合并工作表

chengshanming

有没有高手相助？自己先顶！d=====(￣▽￣*)b一下

zhaogang1960

ADO法不需要传统意义上的打开文件，查询多工作簿速度很快，请参考：

1. Sub ADO法()
   
2.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$, t$, a, arr, i&
   
3.     Application.ScreenUpdating = False
   
4.     arr = Range("A2:J3")
   
5.     For i = 1 To UBound(arr, 2)
   
6.         If arr(2, i) <> "" Then
   
7.             If i = 1 Then
   
8.                 t = t & " and " & arr(1, i) & "=#" & arr(2, i) & "#"
   
9.             Else
   
10.                 t = t & " and " & arr(1, i) & "='" & arr(2, i) & "'"
    
11.             End If
    
12.         End If
    
13.     Next
    
14.     If t = "" Then Exit Sub
    
15.     t = Mid(t, 5)
    
16.     Range("A6:L65536").ClearContents
    
17.     Mypath = ThisWorkbook.Path & ""
    
18.     MyFile = Dir(Mypath & "*.xls")
    
19.     Do While MyFile <> ""
    
20.         If MyFile <> ThisWorkbook.Name Then
    
21.             Set cnn = CreateObject("adodb.connection")
    
22.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=excel 8.0;Data Source=" & Mypath & MyFile
    
23.             Set rs = cnn.OpenSchema(20)
    
24.             Do Until rs.EOF
    
25.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
26.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
27.                     If Right(s, 1) = "$" Then
    
28.                         Set rst = cnn.Execute("[" & s & "a3:a3]")
    
29.                         If rst.Fields(0).Name = "生产日期" Then
    
30.                             SQL = "select 生产日期,处理结果,产品名称,产品编码,防伪码,入库,生产部门,生产车间,质检员,备注,'" & Replace(MyFile, ".xls", "") & "','" & Replace(s, "$", "") & "' from [" & s & "a3:j] where" & t
    
31.                             Set rst = cnn.Execute(SQL)
    
32.                             If Not rst.EOF Then Range("a65536").End(xlUp).Offset(1).CopyFromRecordset rst
    
33.                         End If
    
34.                     End If
    
35.                 End If
    
36.                 rs.MoveNext
    
37.             Loop
    
38.         End If
    
39.         MyFile = Dir()
    
40.     Loop
    
41.     rs.Close
    
42.     Set rs = Nothing
    
43.     rst.Close
    
44.     Set rst = Nothing
    
45.     cnn.Close
    
46.     Set cnn = Nothing
    
47. End Sub
    

复制代码

zhaogang1960

请测试附件
多工作薄查询.rar (38.22 KB, 下载次数: 196)

2016-1-19 21:02 上传

点击文件名下载附件

chengshanming

zhaogang1960 发表于 2016-1-19 21:03
请测试附件

赵刚老师好！你太牛叉了！！我测试下。

chengshanming

zhaogang1960 发表于 2016-1-19 21:03
请测试附件

赵版，如果某工作薄中有一张sheet1等等工作表，会提示以下运行错误。怎么处理？

chengshanming

chengshanming 发表于 2016-1-19 22:11
赵版，如果某工作薄中有一张sheet1等等工作表，会提示以下运行错误。怎么处理？

漏掉了是存在空白工作表，会提示错误！

zhaogang1960

chengshanming 发表于 2016-1-19 22:11
赵版，如果某工作薄中有一张sheet1等等工作表，会提示以下运行错误。怎么处理？

加上容错处理语句：

1. Sub ADO法()
   
2.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$, t$, a, arr, i&
   
3.     Application.ScreenUpdating = False
   
4.     arr = Range("A2:J3")
   
5.     For i = 1 To UBound(arr, 2)
   
6.         If arr(2, i) <> "" Then
   
7.             If i = 1 Then
   
8.                 t = t & " and " & arr(1, i) & "=#" & arr(2, i) & "#"
   
9.             Else
   
10.                 t = t & " and " & arr(1, i) & "='" & arr(2, i) & "'"
    
11.             End If
    
12.         End If
    
13.     Next
    
14.     If t = "" Then Exit Sub
    
15.     t = Mid(t, 5)
    
16.     Range("A6:L65536").ClearContents
    
17.     On Error Resume Next
    
18.     Mypath = ThisWorkbook.Path & ""
    
19.     MyFile = Dir(Mypath & "*.xls")
    
20.     Do While MyFile <> ""
    
21.         If MyFile <> ThisWorkbook.Name Then
    
22.             Set cnn = CreateObject("adodb.connection")
    
23.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=excel 8.0;Data Source=" & Mypath & MyFile
    
24.             Set rs = cnn.OpenSchema(20)
    
25.             Do Until rs.EOF
    
26.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
27.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
28.                     If Right(s, 1) = "$" Then
    
29.                         Set rst = cnn.Execute("[" & s & "a3:a3]")
    
30.                         If Err.Number = 0 Then
    
31.                             If rst.Fields(0).Name = "生产日期" Then
    
32.                                 SQL = "select 生产日期,处理结果,产品名称,产品编码,防伪码,入库,生产部门,生产车间,质检员,备注,'" & Replace(MyFile, ".xls", "") & "','" & Replace(s, "$", "") & "' from [" & s & "a3:j] where" & t
    
33.                                 Set rst = cnn.Execute(SQL)
    
34.                                 If Not rst.EOF Then Range("a65536").End(xlUp).Offset(1).CopyFromRecordset rst
    
35.                             End If
    
36.                         Else
    
37.                             Err.Clear
    
38.                         End If
    
39.                     End If
    
40.                 End If
    
41.                 rs.MoveNext
    
42.             Loop
    
43.         End If
    
44.         MyFile = Dir()
    
45.     Loop
    
46.     rs.Close
    
47.     Set rs = Nothing
    
48.     rst.Close
    
49.     Set rst = Nothing
    
50.     cnn.Close
    
51.     Set cnn = Nothing
    
52. End Sub
    

复制代码

zhaogang1960

下面附件中各插入了一张新表，请测试：
多工作薄查询.rar (41.44 KB, 下载次数: 188)

2016-1-19 22:23 上传

点击文件名下载附件