[已解决]一表分别与多表比较查询的问题

李全有

附件 查询相同附件.zip (388.84 KB, 下载次数: 8)

2015-3-20 17:05 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-20 17:33

………………

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, n%, n2%, j%, zf$$, s&
   
3. Sheet1.Activate
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheet2.Range("a1").CurrentRegion
   
6. n = UBound(arr, 2)
   
7. For i = 2 To UBound(arr)
   
8.     zf = arr(i, n - 1) & "," & arr(i, n)
   
9.     d(zf) = i
   
10. Next
    
11. For j = 3 To Sheets.Count
    
12.     brr = Sheets(j).Range("a1").CurrentRegion
    
13.     n2 = UBound(brr, 2)
    
14.     For i = 1 To UBound(brr)
    
15.         zf = brr(i, n2 - 1) & "," & brr(i, n2)
    
16.         If d.exists(zf) Then
    
17.             s = s + 1
    
18.             Sheet2.Cells(d(zf), 1).Resize(1, n).Copy Cells((s - 1) * 3 + 1, 1)
    
19.             Sheets(j).Cells(i, 1).Resize(1, n2).Copy Cells((s - 1) * 3 + 2, 1)
    
20.         End If
    
21.     Next
    
22. Next
    
23. End Sub

复制代码

dsmch

………………

26759761@qq.com

1. Sub x()
   
2. Dim ar, st, br, x, y, r, l, cr(1 To 60000, 1 To 52)
   
3.   ar = Sheets("SheetA").Range("a1").CurrentRegion
   
4. For Each st In Sheets
   
5.    If st.Name <> "Sheet0" And st.Name <> "SheetA" Then
   
6.      br = st.Range("a1").CurrentRegion
   
7.        For x = 1 To UBound(ar)
   
8.          For y = 1 To UBound(br)
   
9.            If ar(x, 51) & ar(x, 52) = br(y, 51) & br(y, 52) Then
   
10.              r = r + 1
    
11.              For l = 1 To 52
    
12.                cr(r, l) = ar(x, l): cr(r + 1, l) = br(y, l)
    
13.              Next: r = r + 2
    
14.            End If
    
15.          Next
    
16.        Next
    
17.    End If
    
18. Next
    
19. Sheet1.Select: [a:az].Clear
    
20. [a1].Resize(r + 1, 52) = cr
    
21. MsgBox "计算完毕"
    
22. End Sub
    

复制代码