请教老师：用ADO+SQL完成多列数据匹配，谢谢！

qx-liuwx

如题、详见附件，有劳高手！

chxw68

1. Sub test()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   mybook = ThisWorkbook.FullName
   
7.   With cnn
   
8.     If Application.Version = "11.0" Then
   
9.       .Provider = "microsoft.jet.oledb.4.0"
   
10.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
    
11.     Else
    
12.       .Provider = "microsoft.ACE.oledb.12.0"
    
13.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;"";data source=" & mybook
    
14.     End If
    
15.     .Open
    
16.   End With
    
17.   sql = "select * from (select a.类,null,null,null,b.类个数,b.数据1平均值,b.数据2平均值,b.数据3平均值,c.类个数,c.数据1平均值,c.数据2平均值,c.数据3平均值 from ([sheet1$i19:i] a left outer join [正$a:e] b on a.类=b.类) left outer join [负$a:e] c on a.类=c.类) where not isnull(类)"
    
18.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
19.   With Worksheets("sheet1")
    
20.     .Range("i20").CopyFromRecordset rs
    
21.   End With
    
22. End Sub
    

复制代码

chxw68

你试试看。

qx-liuwx

chxw68 发表于 2016-8-27 11:09
你试试看。

感谢老师，可以了。

但还想请教老师，如果将表“正”、“负”放到另一个工作簿要如何修改代码。我试着修改但未成功。重新上个附件，谢谢！麻烦老师继续指导

qx-liuwx

这样可行：
sql = "select * from (select a.类,null,null,null,b.类个数,b.数据1平均值,b.数据2平均值,b.数据3平均值,c.类个数,c.数据1平均值,c.数据2平均值,c.数据3平均值 from ([sheet1$i19:i] a left outer join [Excel 8.0;Database=" & ThisWorkbook.Path & "\正负.xls" & "].[正$a:e] b on a.类=b.类) left outer join [Excel 8.0;Database=" & ThisWorkbook.Path & "\正负.xls" & "].[负$a:e] c on a.类=c.类) where not isnull(类)"

qx-liuwx

chxw68 发表于 2016-8-27 11:08

但这样运算的结果仍是不能匹配65536行以上的数据。麻烦老师指导，谢谢！

qx-liuwx

from ([sheet1$]
这个是关键。但类要放在第1列

qx-liuwx

chxw68 发表于 2016-8-27 11:09
你试试看。

惭愧，改了个形式想继续以ADO代码完成，我又搞不定，敬请老师继续指导，谢谢！

chxw68

qx-liuwx 发表于 2017-8-7 16:54
惭愧，改了个形式想继续以ADO代码完成，我又搞不定，敬请老师继续指导，谢谢！

你有多少数据？这个问题用ADO实现起来很复杂，可能速度也慢得无法忍受。你没试过没知道，这个问题用字典可能要更快一些。

chxw68

1. Sub test1()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("sheet1")
   
9.     r = .Cells(.Rows.Count, 9).End(xlUp).Row
   
10.     arr = .Range("i20:j" & r)
    
11.     For i = 1 To UBound(arr)
    
12.       xm = CStr(arr(i, 1))
    
13.       If Not d.exists(xm) Then
    
14.         Set d(xm) = CreateObject("scripting.dictionary")
    
15.       End If
    
16.       d(xm)(arr(i, 2)) = i
    
17.     Next
    
18.     ReDim brr(1 To UBound(arr), 1 To 2)
    
19.   End With
    
20.   k = 0
    
21.   For Each ws In Worksheets(Array("正", "负"))
    
22.     k = k + 1
    
23.     With ws
    
24.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
25.       crr = .Range("a1:e" & r)
    
26.       For i = 2 To UBound(crr)
    
27.         xm = CStr(crr(i, 1))
    
28.         If d.exists(xm) Then
    
29.           For j = 2 To UBound(crr, 2)
    
30.             If d(xm).exists(crr(1, j)) Then
    
31.               m = d(xm)(crr(1, j))
    
32.               brr(m, k) = crr(i, j)
    
33.             End If
    
34.           Next
    
35.         End If
    
36.       Next
    
37.     End With
    
38.   Next
    
39.   With Worksheets("sheet1")
    
40.     .Range("o20").Resize(UBound(brr), 2) = brr
    
41.   End With
    
42. End Sub
    

复制代码