希望通过SQL提取数据

jackyljc

按FILE“INV_Check"的“rule" sheet 中，按填入的条件去其他DOWNLOAD file中查找符合条件的整行数据提取到sheet "result"中。应为DOWNLOAD文件很大而且有很多，希望通过SQL等高效的方式提取，谢谢了

zhaogang1960

请参考：

1. Sub SQL法()
   
2.     Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, arr, a, b, s$, m&, n&, i&, j&, r
   
3.     Application.ScreenUpdating = False
   
4.     arr = Sheets("Rule").[a7].CurrentRegion
   
5.     a = Array("", "", "'", "'", "#", "'", "'", "")
   
6.     b = Array("SEGMENT1", "VENDOR_NAME", "INVOICE_DATE", "INVOICE_NUM", "INVOICE_CURRENCY_CODE", "INVOICE_AMOUNT")
   
7.     For i = 2 To UBound(arr)
   
8.         s = s & " or "
   
9.         m = 0
   
10.         For j = 2 To 7
    
11.             If Len(arr(i, j)) Then
    
12.                 m = m + 1
    
13.                 If m = 1 Then
    
14.                     s = s & b(j - 2) & "=" & a(j) & arr(i, j) & a(j)
    
15.                 Else
    
16.                     s = s & " and " & b(j - 2) & "=" & a(j) & arr(i, j) & a(j)
    
17.                 End If
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     If s = "" Then Exit Sub
    
22.     r = 2
    
23.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
24.     Set cnn = CreateObject("adodb.connection")
    
25.     With Sheets("Result")
    
26.         .UsedRange.Offset(1).ClearContents
    
27.         For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
    
28.             If File.Name Like "*.xlsx" Then
    
29.                 n = n + 1
    
30.                 If n = 1 Then
    
31.                     cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & File
    
32.                     SQL = "select " & Join(b, ",") & " from [Download_Invoice_Capex$] where " & Mid(s, 4)
    
33.                 Else
    
34.                     SQL = "select " & Join(b, ",") & " from [Excel 12.0;Database=" & File & ";].[Download_Invoice_Capex$] where " & Mid(s, 4)
    
35.                 End If
    
36.                 Set rs = CreateObject("adodb.recordset")
    
37.                 rs.Open SQL, cnn, 1, 3
    
38.                 If rs.RecordCount Then
    
39.                     .Range("A" & r).CopyFromRecordset rs
    
40.                     r = r + rs.RecordCount
    
41.                 End If
    
42.             End If
    
43.         Next
    
44.     End With
    
45.     rs.Close
    
46.     cnn.Close
    
47.     Set rs = Nothing
    
48.     Set cnn = Nothing
    
49.     Set File = Nothing
    
50.     Set Fso = Nothing
    
51.     Application.ScreenUpdating = True
    
52. End Sub
    

复制代码

zhaogang1960

请测试附件
New folder (4).rar (207.2 KB, 下载次数: 37)

2015-11-12 17:03 上传

点击文件名下载附件

jackyljc

zhaogang1960 发表于 2015-11-12 17:03
请测试附件

万分感谢斑竹的回复，发现一个问题，DOWNLOAD文件原来每个SHEET的名字都有差别，可以定义为第一个sheet, 或文件中所有SHEET吗？

zhaogang1960

jackyljc 发表于 2015-11-12 17:16
万分感谢斑竹的回复，发现一个问题，DOWNLOAD文件原来每个SHEET的名字都有差别，可以定义为第一个sheet,  ...

1. Sub SQL法()
   
2.     Dim Fso As Object, File As Object, cnn As Object, rs As Object, rst As Object, SQL$, arr, a, b, s$, m&, n&, i&, j&, r, tb$
   
3.     Application.ScreenUpdating = False
   
4.     arr = Sheets("Rule").[a7].CurrentRegion
   
5.     a = Array("", "", "'", "'", "#", "'", "'", "")
   
6.     b = Array("SEGMENT1", "VENDOR_NAME", "INVOICE_DATE", "INVOICE_NUM", "INVOICE_CURRENCY_CODE", "INVOICE_AMOUNT")
   
7.     For i = 2 To UBound(arr)
   
8.         s = s & " or "
   
9.         m = 0
   
10.         For j = 2 To 7
    
11.             If Len(arr(i, j)) Then
    
12.                 m = m + 1
    
13.                 If m = 1 Then
    
14.                     s = s & b(j - 2) & "=" & a(j) & arr(i, j) & a(j)
    
15.                 Else
    
16.                     s = s & " and " & b(j - 2) & "=" & a(j) & arr(i, j) & a(j)
    
17.                 End If
    
18.             End If
    
19.         Next
    
20.     Next
    
21.     If s = "" Then Exit Sub
    
22.     r = 2
    
23.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
24.     With Sheets("Result")
    
25.         .UsedRange.Offset(1).ClearContents
    
26.         For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
    
27.             If File.Name Like "*.xlsx" Then
    
28.                 Set cnn = CreateObject("adodb.connection")
    
29.                 cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & File
    
30.                 Set rst = cnn.OpenSchema(20)
    
31.                 Do Until rst.EOF
    
32.                     If rst.Fields("TABLE_TYPE") = "TABLE" Then
    
33.                         tb = rst("TABLE_NAME").Value
    
34.                         If Right(tb, 1) = "$" Then
    
35.                             SQL = "select " & Join(b, ",") & " from [" & tb & "] where " & Mid(s, 4)
    
36.                             Set rs = CreateObject("adodb.recordset")
    
37.                             rs.Open SQL, cnn, 1, 3
    
38.                             If rs.RecordCount Then
    
39.                                 .Range("A" & r).CopyFromRecordset rs
    
40.                                 r = r + rs.RecordCount
    
41.                             End If
    
42.                         End If
    
43.                     End If
    
44.                     rst.MoveNext
    
45.                 Loop
    
46.             End If
    
47.         Next
    
48.     End With
    
49.     rs.Close
    
50.     rst.Close
    
51.     cnn.Close
    
52.     Set rs = Nothing
    
53.     Set rst = Nothing
    
54.     Set cnn = Nothing
    
55.     Set File = Nothing
    
56.     Set Fso = Nothing
    
57.     Application.ScreenUpdating = True
    
58. End Sub
    

复制代码

zhaogang1960

SQL不能确定每个工作簿中的第一个工作表，下面附件复制所有工作表数据
New folder (4).rar (208.98 KB, 下载次数: 35)

2015-11-12 17:27 上传

点击文件名下载附件

jackyljc

zhaogang1960 发表于 2015-11-12 17:27
SQL不能确定每个工作簿中的第一个工作表，下面附件复制所有工作表数据

显示“Data type mismatch in criteria expression" error

zhaogang1960

jackyljc 发表于 2015-11-12 17:40
显示“Data type mismatch in criteria expression" error

应该是数据类型不正确，我测试没有发现这个问题，你是否已经更换了数据源？如果是请上传出错附件分析一下

jackyljc

就是加了这个文件，原文件太大传布了，只截取10000行

zhaogang1960

jackyljc 发表于 2015-11-12 18:17
就是加了这个文件，原文件太大传布了，只截取10000行

INVOICE_NUM字段数字文本混排，不适合作为查询条件，也不适合使用SQL方法：
INVOICE_NUM
175
181
176
180
182
DSMD0514-295738
DF183
177
179
184
DSMD0614-297848
185
192
190
DSMD0914-304608