多工作薄多条件查询求助

chengshanming

zhaogang1960 发表于 2016-1-19 22:23
下面附件中各插入了一张新表，请测试：

可以了，谢谢老师！要的就是要各种情况都通用。

chengshanming

zhaogang1960 发表于 2016-1-19 22:23
下面附件中各插入了一张新表，请测试：

赵老师好！以下附件为何运行不了？还是您昨天帮忙写的代码，我改下了需求格式式样。
还有就是同一列或行，是否文本与数值格式都适应。同时另外新增一个工作薄，随便命个名都没反应。谢谢老师了！

zhaogang1960

chengshanming 发表于 2016-1-20 10:28
赵老师好！以下附件为何运行不了？还是您昨天帮忙写的代码，我改下了需求格式式样。
还有就是同一列或行 ...

经测试，待查询工作簿不是真正的xls文件，应该是把xlsx文件人工修改成的xls文件，下面程序请在2007或2010版本中使用：

1. Sub ADO法()
   
2.     t1 = Timer
   
3.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$, t$, a, arr, i&, v$
   
4.     Application.ScreenUpdating = False
   
5.     Dim objWMI As Object
   
6.     Const HKEY_LOCAL_MACHINE = &H80000002
   
7.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
8.     arr = Range("A2:F3")
   
9.     For i = 1 To UBound(arr, 2)
   
10.         If arr(2, i) <> "" Then
    
11.             If i = 1 Then
    
12.                 t = t & " and " & arr(1, i) & "=#" & arr(2, i) & "#"
    
13.             Else
    
14.                 t = t & " and " & arr(1, i) & "='" & arr(2, i) & "'"
    
15.             End If
    
16.         End If
    
17.     Next
    
18.     If t = "" Then Exit Sub
    
19.     t = Mid(t, 5)
    
20.     Range("A6:H65536").ClearContents
    
21.     If Application.Version < 12 Then
    
22.         v = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='excel 8.0;imex=1';Data Source="
    
23.         objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 0
    
24.     Else
    
25.         v = "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='excel 12.0;imex=1';Data Source="
    
26.         objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office" & Application.Version & "\Access Connectivity Engine\Engines\Excel", "TypeGuessRows", 0
    
27.     End If
    
28.     On Error Resume Next
    
29.     Mypath = ThisWorkbook.Path & ""
    
30.     MyFile = Dir(Mypath & "*.xls*")
    
31.     Do While MyFile <> ""
    
32.         If MyFile <> ThisWorkbook.Name Then
    
33.             Set cnn = CreateObject("adodb.connection")
    
34.             cnn.Open v & Mypath & MyFile
    
35.             Set rs = cnn.OpenSchema(20)
    
36.             Do Until rs.EOF
    
37.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
38.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
39.                     If Right(s, 1) = "$" Then
    
40.                         Set rst = cnn.Execute("[" & s & "a2:a]")
    
41.                         If Err.Number = 0 Then
    
42.                             If rst.Fields(0).Name = "成本域编码" Then
    
43.                                 SQL = "select 成本域编码,料号,品名,规格,库存主单位名称,结存单价,'" & Replace(MyFile, ".xls", "") & "','" & Replace(s, "$", "") & "' from [" & s & "a2:F5000] where" & t
    
44.                                 Set rst = cnn.Execute(SQL)
    
45.                                 If Not rst.EOF Then Range("a65536").End(xlUp).Offset(1).CopyFromRecordset rst
    
46.                             End If
    
47.                         Else
    
48.                             Err.Clear
    
49.                         End If
    
50.                     End If
    
51.                 End If
    
52.                 rs.MoveNext
    
53.             Loop
    
54.         End If
    
55.         MyFile = Dir()
    
56.     Loop
    
57.     rs.Close
    
58.     Set rs = Nothing
    
59.     rst.Close
    
60.     Set rst = Nothing
    
61.     cnn.Close
    
62.     Set cnn = Nothing
    
63.     Application.ScreenUpdating = True
    
64.     MsgBox "耗时：" & Format(Timer - t1, "0.00") & "秒！" & Chr(10) & "共有“" & [a65536].End(3).Row - 5 & "”条记录！", vbInformation, "完工"
    
65. End Sub
    
66. 
    

复制代码

zhaogang1960

附件……………………………………………………………………
查询.zip (43.22 KB, 下载次数: 107)

2016-1-20 12:28 上传

点击文件名下载附件

chengshanming

zhaogang1960 发表于 2016-1-20 12:28
附件……………………………………………………………………

谢谢老师了！好像还是没反应。是不是我电脑问题呢，我晚上换一台试一试。

chengshanming

zhaogang1960 发表于 2016-1-20 12:27
经测试，待查询工作簿不是真正的xls文件，应该是把xlsx文件人工修改成的xls文件，下面程序请在2007或2010 ...

老师，可以正常运行了，谢谢了！但还有个小需求，就是我的工作薄有30来个，每个工作薄中只有一个工作表，每个工作表有5000来行数据。查起来需要25s左右，这个速度有没有办法更快一点？

zhaogang1960

chengshanming 发表于 2016-1-20 14:27
老师，可以正常运行了，谢谢了！但还有个小需求，就是我的工作薄有30来个，每个工作薄中只有一个工作表， ...

要求越复杂，运行速度越慢，下面采用ADO加数组，不知道速度是否会提高：

1. Sub ADO加数组法()
   
2.     t1 = Timer
   
3.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$, t$, a, arr, brr(1 To 150000, 7), i&, j&, m&, v$
   
4.     Application.ScreenUpdating = False
   
5.     Dim objWMI As Object
   
6.     Const HKEY_LOCAL_MACHINE = &H80000002
   
7.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
8.     arr = Range("A2:F3")
   
9.     For i = 1 To UBound(arr, 2)
   
10.         If arr(2, i) <> "" Then
    
11.             If i = 1 Then
    
12.                 t = t & " and " & arr(1, i) & "=#" & arr(2, i) & "#"
    
13.             Else
    
14.                 t = t & " and " & arr(1, i) & "='" & arr(2, i) & "'"
    
15.             End If
    
16.         End If
    
17.     Next
    
18.     If t = "" Then Exit Sub
    
19.     t = Mid(t, 5)
    
20.     If Application.Version < 12 Then
    
21.         v = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='excel 8.0;imex=1';Data Source="
    
22.         objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 0
    
23.     Else
    
24.         v = "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='excel 12.0;imex=1';Data Source="
    
25.         objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office" & Application.Version & "\Access Connectivity Engine\Engines\Excel", "TypeGuessRows", 0
    
26.     End If
    
27.     On Error Resume Next
    
28.     Mypath = ThisWorkbook.Path & ""
    
29.     MyFile = Dir(Mypath & "*.xls*")
    
30.     Do While MyFile <> ""
    
31.         If InStr(MyFile, ThisWorkbook.Name) = 0 Then
    
32.             Set cnn = CreateObject("adodb.connection")
    
33.             cnn.Open v & Mypath & MyFile
    
34.             Set rs = cnn.OpenSchema(20)
    
35.             Do Until rs.EOF
    
36.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
37.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
38.                     If Right(s, 1) = "$" Then
    
39.                         Set rst = cnn.Execute("[" & s & "a2:a]")
    
40.                         If Err.Number = 0 Then
    
41.                             If rst.Fields(0).Name = "成本域编码" Then
    
42.                                 SQL = "select * from [" & s & "a2:F5000] where" & t
    
43.                                 Set rst = cnn.Execute(SQL)
    
44.                                 If Not rst.EOF Then
    
45.                                     arr = rst.GetRows
    
46.                                     w = Replace(MyFile, ".xls", "")
    
47.                                     sh = Replace(s, "$", "")
    
48.                                     For i = 0 To UBound(arr, 2)
    
49.                                         m = m + 1
    
50.                                         For j = 0 To 5
    
51.                                             brr(m, j) = arr(j, i)
    
52.                                         Next
    
53.                                         brr(m, 6) = w
    
54.                                         brr(m, 7) = sh
    
55.                                     Next
    
56.                                 End If
    
57.                             End If
    
58.                         Else
    
59.                             Err.Clear
    
60.                         End If
    
61.                     End If
    
62.                 End If
    
63.                 rs.MoveNext
    
64.             Loop
    
65.         End If
    
66.         MyFile = Dir()
    
67.     Loop
    
68.     Range("A6:H65536").ClearContents
    
69.     Range("A6").Resize(m, 8) = brr
    
70.     rs.Close
    
71.     Set rs = Nothing
    
72.     rst.Close
    
73.     Set rst = Nothing
    
74.     cnn.Close
    
75.     Set cnn = Nothing
    
76.     Application.ScreenUpdating = True
    
77.     MsgBox "耗时：" & Format(Timer - t1, "0.00") & "秒！" & Chr(10) & "共有“" & [a65536].End(3).Row - 5 & "”条记录！", vbInformation, "完工"
    
78. End Sub
    
79. 
    

复制代码

zhaogang1960

ADO+数组法在2003中快些，但在2010中不一定比ADO快，下面附件中有15个待查询工作簿，每个都有5000行数据，请测试：
查询.rar (1.7 MB, 下载次数: 133)

2016-1-20 15:48 上传

点击文件名下载附件

chengshanming

zhaogang1960 发表于 2016-1-20 12:27
经测试，待查询工作簿不是真正的xls文件，应该是把xlsx文件人工修改成的xls文件，下面程序请在2007或2010 ...

赵老师晚上好，有个问题续请教！（如截图）就是查询条件栏 遇到列字段是 文本格式字母或是数字取数时都查不出明细，需怎么处理？

zhaogang1960

chengshanming 发表于 2016-1-20 19:59
赵老师晚上好，有个问题续请教！（如截图）就是查询条件栏 遇到列字段是 文本格式字母或是数字取数时都查 ...

代码不通用，修改时应该注意数据类型，原来第一个字段是日期，现在变成了文本：

1. Sub ADO加数组法()
   
2.     t1 = Timer
   
3.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$, t$, a, arr, brr(1 To 10000, 7), i&, j&, m&, v$
   
4.     Application.ScreenUpdating = False
   
5.     Dim objWMI As Object
   
6.     Const HKEY_LOCAL_MACHINE = &H80000002
   
7.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
8.     arr = Range("A2:F3")
   
9.     For i = 1 To 6
   
10.         If arr(2, i) <> "" Then
    
11.             If i < 6 Then
    
12.                 t = t & " and " & arr(1, i) & "='" & arr(2, i) & "'"
    
13.             Else
    
14.                 t = t & " and " & arr(1, i) & "=" & arr(2, i)
    
15.             End If
    
16.         End If
    
17.     Next
    
18.     If t = "" Then Exit Sub
    
19.     t = Mid(t, 5)
    
20.     If Application.Version < 12 Then
    
21.         v = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='excel 8.0;imex=1';Data Source="
    
22.         objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 0
    
23.     Else
    
24.         v = "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='excel 12.0;imex=1';Data Source="
    
25.         objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office" & Application.Version & "\Access Connectivity Engine\Engines\Excel", "TypeGuessRows", 0
    
26.     End If
    
27.     On Error Resume Next
    
28.     Mypath = ThisWorkbook.Path & ""
    
29.     MyFile = Dir(Mypath & "*.xls*")
    
30.     Do While MyFile <> ""
    
31.         If InStr(MyFile, ThisWorkbook.Name) = 0 Then
    
32.             Set cnn = CreateObject("adodb.connection")
    
33.             cnn.Open v & Mypath & MyFile
    
34.             Set rs = cnn.OpenSchema(20)
    
35.             Do Until rs.EOF
    
36.                 If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
37.                     s = Replace(rs("TABLE_NAME").Value, "'", "")
    
38.                     If Right(s, 1) = "$" Then
    
39.                         Set rst = cnn.Execute("[" & s & "a2:a]")
    
40.                         If Err.Number = 0 Then
    
41.                             If rst.Fields(0).Name = "成本域编码" Then
    
42.                                 SQL = "select * from [" & s & "a2:F5000] where" & t
    
43.                                 Set rst = cnn.Execute(SQL)
    
44.                                 If Not rst.EOF Then
    
45.                                     arr = rst.GetRows
    
46.                                     w = Replace(MyFile, ".xls", "")
    
47.                                     sh = Replace(s, "$", "")
    
48.                                     For i = 0 To UBound(arr, 2)
    
49.                                         m = m + 1
    
50.                                         For j = 0 To 5
    
51.                                             brr(m, j) = arr(j, i)
    
52.                                         Next
    
53.                                         brr(m, 6) = w
    
54.                                         brr(m, 7) = sh
    
55.                                     Next
    
56.                                 End If
    
57.                             End If
    
58.                         Else
    
59.                             Err.Clear
    
60.                         End If
    
61.                     End If
    
62.                 End If
    
63.                 rs.MoveNext
    
64.             Loop
    
65.         End If
    
66.         MyFile = Dir()
    
67.     Loop
    
68.     Range("A6:H65536").ClearContents
    
69.     Range("A6").Resize(m, 8) = brr
    
70.     rs.Close
    
71.     Set rs = Nothing
    
72.     rst.Close
    
73.     Set rst = Nothing
    
74.     cnn.Close
    
75.     Set cnn = Nothing
    
76.     Application.ScreenUpdating = True
    
77.     MsgBox "耗时：" & Format(Timer - t1, "0.00") & "秒！" & Chr(10) & "共有“" & [a65536].End(3).Row - 5 & "”条记录！", vbInformation, "完工"
    
78. End Sub
    
79. 
    
80. 
    

复制代码