如何使用宏来查找匹配数据

hefuqing

1. Sub sds()
   
2. Dim brr(), crr()
   
3. arr = [a1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. Set d3 = CreateObject("scripting.dictionary")
   
8. For i = 1 To UBound(arr)
   
9. d(arr(i, 1) & "/" & arr(i, 2)) = ""
   
10. d2(arr(i, 1) & "/" & arr(i, 3)) = ""
    
11. Next
    
12. k = d.keys
    
13. k2 = d2.keys
    
14. 
    
15. For i = 0 To d.Count - 1
    
16. n = n + 1
    
17. ReDim Preserve brr(1 To 3, 1 To n)
    
18. brr(1, n) = Split(k(i), "/")(0)
    
19. brr(2, n) = Split(k(i), "/")(1)
    
20. Next
    
21. 
    
22. For i = 0 To d2.Count - 1
    
23. n2 = n2 + 1
    
24. ReDim Preserve crr(1 To 3, 1 To n2)
    
25. crr(1, n2) = Split(k2(i), "/")(0)
    
26. crr(2, n2) = Split(k2(i), "/")(1)
    
27. Next
    
28. 
    
29. For i = 1 To UBound(brr, 2)
    
30. d1(brr(1, i)) = d1(brr(1, i)) & "/" & brr(2, i)
    
31. Next
    
32. k1 = d1.keys
    
33. t1 = d1.items
    
34. 
    
35. For i = 1 To UBound(crr, 2)
    
36. d3(crr(1, i)) = d3(crr(1, i)) & "/" & crr(2, i)
    
37. Next
    
38. k3 = d3.keys
    
39. t3 = d3.items
    
40. 
    
41. [F1].Resize(d1.Count, 1) = Application.Transpose(k1)
    
42. 
    
43. For i = 0 To d1.Count - 1
    
44. n1 = n1 + 1
    
45. Cells(n1, 7) = Mid(t1(i), 2)
    
46. Next
    
47. 
    
48. For i = 0 To d3.Count - 1
    
49. n3 = n3 + 1
    
50. Cells(n3, 8) = Mid(t3(i), 2)
    
51. Next
    
52. 
    
53. End Sub

复制代码