[已解决]VBA字典求解！

听评点菜

问题如表，求高手指点！深表感谢！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-5-8 22:24

对于实际应用中如果列数不一致，做下判断。

1. Sub test()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : test
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/5/8
   
6. ' Purpose   : 把每行数据转化为字符串作为KEY，以数组形式做为ITEM值存入字典，实现查找相同行
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9.     Dim arrA, arrB, arrTemp, i As Long, strTemp$
   
10.     Dim key1
    
11.     arrA = Range("a2:f6")
    
12.     arrB = Range("h2:m5")
    
13.    
    
14.     If UBound(arrA, 2) <> UBound(arrB, 2) Then MsgBox "数据列数不一致", vbCritical: Exit Sub
    
15.    
    
16.     Dim objDicA As Object, objDicB As Object
    
17.     Set objDicA = CreateObject("scripting.dictionary")
    
18.     Set objDicB = CreateObject("scripting.dictionary")
    
19.     For i = LBound(arrA) To UBound(arrA)
    
20.         arrTemp = WorksheetFunction.Index(arrA, i, 0)
    
21.         strTemp = Join(arrTemp, "#")
    
22.         objDicA(strTemp) = arrTemp
    
23.     Next
    
24. 
    
25.     For i = LBound(arrB) To UBound(arrB)
    
26.         arrTemp = WorksheetFunction.Index(arrB, i, 0)
    
27.         strTemp = Join(arrTemp, "#")
    
28.         objDicB(strTemp) = arrTemp
    
29.     Next
    
30. 
    
31.     i = Cells(Rows.Count, "o").End(xlUp).Row
    
32.     If i > 1 Then Range("o2:t" & i).ClearContents
    
33. 
    
34.     Application.ScreenUpdating = False
    
35.     For Each key1 In objDicA.Keys
    
36.         If objDicB.exists(key1) Then
    
37.             Cells(Rows.Count, "o").End(xlUp).Offset(1).Resize(, UBound(arrA, 2)) = objDicA(key1)
    
38.         End If
    
39.     Next
    
40.     Set objDicA = Nothing
    
41.     Set objDicB = Nothing
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "查找完成"
    
44. End Sub
    
45. 
    
46. Sub test2()
    
47. '---------------------------------------------------------------------------------------
    
48. ' Procedure : test2
    
49. ' Author    : hwc2ycy
    
50. ' Date      : 2013/5/8
    
51. ' Purpose   :把每行数据转化为字符串作为KEY，把数组所在行做为ITEM值存入字典，实现查找相同行
    
52. '---------------------------------------------------------------------------------------
    
53. '
    
54.     Dim arrA, arrB, arrTemp, i As Long, strTemp$
    
55.     Dim key1
    
56.    
    
57.     arrA = Range("a2:f6")
    
58.     arrB = Range("h2:m5")
    
59.     If UBound(arrA, 2) <> UBound(arrB, 2) Then MsgBox "数据列数不一致", vbCritical: Exit Sub
    
60.    
    
61.     Dim objDicA As Object, objDicB As Object
    
62.     Set objDicA = CreateObject("scripting.dictionary")
    
63.     Set objDicB = CreateObject("scripting.dictionary")
    
64.     For i = LBound(arrA) To UBound(arrA)
    
65.         arrTemp = WorksheetFunction.Index(arrA, i, 0)
    
66.         strTemp = Join(arrTemp, "#")
    
67.         objDicA(strTemp) = i
    
68.     Next
    
69. 
    
70.     For i = LBound(arrB) To UBound(arrB)
    
71.         arrTemp = WorksheetFunction.Index(arrB, i, 0)
    
72.         strTemp = Join(arrTemp, "#")
    
73.         objDicB(strTemp) = i
    
74.     Next
    
75. 
    
76.     i = Cells(Rows.Count, "o").End(xlUp).Row
    
77.     If i > 1 Then Range("o2:t" & i).ClearContents
    
78. 
    
79.     Application.ScreenUpdating = False
    
80.     For Each key1 In objDicA.Keys
    
81.         If objDicB.exists(key1) Then
    
82.             Cells(Rows.Count, "o").End(xlUp).Offset(1).Resize(, UBound(arrA, 2)) = WorksheetFunction.Index(arrA, objDicA(key1), 0)
    
83.         End If
    
84.     Next
    
85.     Set objDicA = Nothing
    
86.     Set objDicB = Nothing
    
87.     Application.ScreenUpdating = True
    
88.     MsgBox "查找完成"
    
89. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

是号码相同还是要重复多少次啊

hwc2ycy

1. Sub test()
   
2.     Dim arrA, arrB, arrTemp, i As Long, strTemp$
   
3.     Dim key1
   
4.     arrA = Range("a2:f6")
   
5.     arrB = Range("h2:m5")
   
6.    
   
7.     Dim objDicA As Object, objDicB As Object
   
8.     Set objDicA = CreateObject("scripting.dictionary")
   
9.     Set objDicB = CreateObject("scripting.dictionary")
   
10.     For i = LBound(arrA) To UBound(arrA)
    
11.         arrTemp = WorksheetFunction.Index(arrA, i, 0)
    
12.         strTemp = Join(arrTemp, "#")
    
13.         objDicA(strTemp) = arrTemp
    
14.     Next
    
15. 
    
16.     For i = LBound(arrB) To UBound(arrB)
    
17.         arrTemp = WorksheetFunction.Index(arrB, i, 0)
    
18.         strTemp = Join(arrTemp, "#")
    
19.         objDicB(strTemp) = arrTemp
    
20.     Next
    
21.    
    
22.     i = Cells(Rows.Count, "o").End(xlUp).Row
    
23.     If i > 1 Then Range("o2:t" & i).ClearContents
    
24.    
    
25.     Application.ScreenUpdating = False
    
26.     For Each key1 In objDicA.Keys
    
27.         If objDicB.exists(key1) Then
    
28.             Cells(Rows.Count, "o").End(xlUp).Offset(1).Resize(, 6) = objDicA(key1)
    
29.         End If
    
30.     Next
    
31.     Set objDicA = Nothing
    
32.     Set objDicB = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "查找完成"
    
35. End Sub

复制代码

hwc2ycy

1. Sub test()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : test
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/5/8
   
6. ' Purpose   : 把每行数据转化为字符串作为KEY，以数组形式做为ITEM值存入字典，实现查找相同行
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9.     Dim arrA, arrB, arrTemp, i As Long, strTemp$
   
10.     Dim key1
    
11.     arrA = Range("a2:f6")
    
12.     arrB = Range("h2:m5")
    
13. 
    
14.     Dim objDicA As Object, objDicB As Object
    
15.     Set objDicA = CreateObject("scripting.dictionary")
    
16.     Set objDicB = CreateObject("scripting.dictionary")
    
17.     For i = LBound(arrA) To UBound(arrA)
    
18.         arrTemp = WorksheetFunction.Index(arrA, i, 0)
    
19.         strTemp = Join(arrTemp, "#")
    
20.         objDicA(strTemp) = arrTemp
    
21.     Next
    
22. 
    
23.     For i = LBound(arrB) To UBound(arrB)
    
24.         arrTemp = WorksheetFunction.Index(arrB, i, 0)
    
25.         strTemp = Join(arrTemp, "#")
    
26.         objDicB(strTemp) = arrTemp
    
27.     Next
    
28. 
    
29.     i = Cells(Rows.Count, "o").End(xlUp).Row
    
30.     If i > 1 Then Range("o2:t" & i).ClearContents
    
31. 
    
32.     Application.ScreenUpdating = False
    
33.     For Each key1 In objDicA.Keys
    
34.         If objDicB.exists(key1) Then
    
35.             Cells(Rows.Count, "o").End(xlUp).Offset(1).Resize(, 6) = objDicA(key1)
    
36.         End If
    
37.     Next
    
38.     Set objDicA = Nothing
    
39.     Set objDicB = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "查找完成"
    
42. End Sub
    
43. 
    
44. Sub test2()
    
45. '---------------------------------------------------------------------------------------
    
46. ' Procedure : test2
    
47. ' Author    : hwc2ycy
    
48. ' Date      : 2013/5/8
    
49. ' Purpose   :把每行数据转化为字符串作为KEY，把数组所在行做为ITEM值存入字典，实现查找相同行
    
50. '---------------------------------------------------------------------------------------
    
51. '
    
52.     Dim arrA, arrB, arrTemp, i As Long, strTemp$
    
53.     Dim key1
    
54.     arrA = Range("a2:f6")
    
55.     arrB = Range("h2:m5")
    
56. 
    
57.     Dim objDicA As Object, objDicB As Object
    
58.     Set objDicA = CreateObject("scripting.dictionary")
    
59.     Set objDicB = CreateObject("scripting.dictionary")
    
60.     For i = LBound(arrA) To UBound(arrA)
    
61.         arrTemp = WorksheetFunction.Index(arrA, i, 0)
    
62.         strTemp = Join(arrTemp, "#")
    
63.         objDicA(strTemp) = i
    
64.     Next
    
65. 
    
66.     For i = LBound(arrB) To UBound(arrB)
    
67.         arrTemp = WorksheetFunction.Index(arrB, i, 0)
    
68.         strTemp = Join(arrTemp, "#")
    
69.         objDicB(strTemp) = i
    
70.     Next
    
71. 
    
72.     i = Cells(Rows.Count, "o").End(xlUp).Row
    
73.     If i > 1 Then Range("o2:t" & i).ClearContents
    
74. 
    
75.     Application.ScreenUpdating = False
    
76.     For Each key1 In objDicA.Keys
    
77.         If objDicB.exists(key1) Then
    
78.             Cells(Rows.Count, "o").End(xlUp).Offset(1).Resize(, 6) = WorksheetFunction.Index(arrA, objDicA(key1), 0)
    
79.         End If
    
80.     Next
    
81.     Set objDicA = Nothing
    
82.     Set objDicB = Nothing
    
83.     Application.ScreenUpdating = True
    
84.     MsgBox "查找完成"
    
85. End Sub

复制代码

hwc2ycy

查找相同行.rar (12.31 KB, 下载次数: 9)

2013-5-8 22:20 上传

点击文件名下载附件

hwc2ycy

Resize(, 6)可以改为resize(,ubound(arra,2))

hwc2ycy

对于实际应用中如果列数不一致，做下判断。

1. Sub test()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : test
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/5/8
   
6. ' Purpose   : 把每行数据转化为字符串作为KEY，以数组形式做为ITEM值存入字典，实现查找相同行
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9.     Dim arrA, arrB, arrTemp, i As Long, strTemp$
   
10.     Dim key1
    
11.     arrA = Range("a2:f6")
    
12.     arrB = Range("h2:m5")
    
13.    
    
14.     If UBound(arrA, 2) <> UBound(arrB, 2) Then MsgBox "数据列数不一致", vbCritical: Exit Sub
    
15.    
    
16.     Dim objDicA As Object, objDicB As Object
    
17.     Set objDicA = CreateObject("scripting.dictionary")
    
18.     Set objDicB = CreateObject("scripting.dictionary")
    
19.     For i = LBound(arrA) To UBound(arrA)
    
20.         arrTemp = WorksheetFunction.Index(arrA, i, 0)
    
21.         strTemp = Join(arrTemp, "#")
    
22.         objDicA(strTemp) = arrTemp
    
23.     Next
    
24. 
    
25.     For i = LBound(arrB) To UBound(arrB)
    
26.         arrTemp = WorksheetFunction.Index(arrB, i, 0)
    
27.         strTemp = Join(arrTemp, "#")
    
28.         objDicB(strTemp) = arrTemp
    
29.     Next
    
30. 
    
31.     i = Cells(Rows.Count, "o").End(xlUp).Row
    
32.     If i > 1 Then Range("o2:t" & i).ClearContents
    
33. 
    
34.     Application.ScreenUpdating = False
    
35.     For Each key1 In objDicA.Keys
    
36.         If objDicB.exists(key1) Then
    
37.             Cells(Rows.Count, "o").End(xlUp).Offset(1).Resize(, UBound(arrA, 2)) = objDicA(key1)
    
38.         End If
    
39.     Next
    
40.     Set objDicA = Nothing
    
41.     Set objDicB = Nothing
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "查找完成"
    
44. End Sub
    
45. 
    
46. Sub test2()
    
47. '---------------------------------------------------------------------------------------
    
48. ' Procedure : test2
    
49. ' Author    : hwc2ycy
    
50. ' Date      : 2013/5/8
    
51. ' Purpose   :把每行数据转化为字符串作为KEY，把数组所在行做为ITEM值存入字典，实现查找相同行
    
52. '---------------------------------------------------------------------------------------
    
53. '
    
54.     Dim arrA, arrB, arrTemp, i As Long, strTemp$
    
55.     Dim key1
    
56.    
    
57.     arrA = Range("a2:f6")
    
58.     arrB = Range("h2:m5")
    
59.     If UBound(arrA, 2) <> UBound(arrB, 2) Then MsgBox "数据列数不一致", vbCritical: Exit Sub
    
60.    
    
61.     Dim objDicA As Object, objDicB As Object
    
62.     Set objDicA = CreateObject("scripting.dictionary")
    
63.     Set objDicB = CreateObject("scripting.dictionary")
    
64.     For i = LBound(arrA) To UBound(arrA)
    
65.         arrTemp = WorksheetFunction.Index(arrA, i, 0)
    
66.         strTemp = Join(arrTemp, "#")
    
67.         objDicA(strTemp) = i
    
68.     Next
    
69. 
    
70.     For i = LBound(arrB) To UBound(arrB)
    
71.         arrTemp = WorksheetFunction.Index(arrB, i, 0)
    
72.         strTemp = Join(arrTemp, "#")
    
73.         objDicB(strTemp) = i
    
74.     Next
    
75. 
    
76.     i = Cells(Rows.Count, "o").End(xlUp).Row
    
77.     If i > 1 Then Range("o2:t" & i).ClearContents
    
78. 
    
79.     Application.ScreenUpdating = False
    
80.     For Each key1 In objDicA.Keys
    
81.         If objDicB.exists(key1) Then
    
82.             Cells(Rows.Count, "o").End(xlUp).Offset(1).Resize(, UBound(arrA, 2)) = WorksheetFunction.Index(arrA, objDicA(key1), 0)
    
83.         End If
    
84.     Next
    
85.     Set objDicA = Nothing
    
86.     Set objDicB = Nothing
    
87.     Application.ScreenUpdating = True
    
88.     MsgBox "查找完成"
    
89. End Sub
    

复制代码

听评点菜

感谢hwc2ycy 班管用数组和字典方式的解答，非常感谢！

在实际应用中列数是一样的，只是行数有多有少，几万行是有的。

如果要改是否可将arrA = Range("a2:f20000")  arrB = Range("h2:m20000")  


   

hwc2ycy

可以。

hwc2ycy

区域是灵活的，输出益你也可以根据自己的需求改。