[已解决]VBA统计判断某人的数据与其他人数据的重复个数

陈俊超

VBA统计判断某人的数据与其他人数据的重复个数，如陈某有1、2、2、4、5，李某有2、4、5、7、11，张某有3、4、5、11，判断出陈李两人重复数据为3个,陈张为2个，李张为3个。

最佳答案

月排行榜 / 总排行榜

sam-wang

2022-1-7 12:41

陈俊超 发表于 2022-1-7 16:20
好的，我试一下

後學怕資料多您不容易確認，有額外再另一個工作表示範，程式也有小修改且新增另外一種呈現方式如圖片，
請再測試看看，謝謝

跳转到最佳答案楼层

sam-wang

陈俊超 发表于 2022-1-7 16:20
好的，我试一下

後學怕資料多您不容易確認，有額外再另一個工作表示範，程式也有小修改且新增另外一種呈現方式如圖片，
請再測試看看，謝謝

陈俊超

这是数据格式

sam-wang

陈俊超 发表于 2022-1-7 12:45
这是数据格式

請測試看看，謝謝
Sub test()
Dim Arr, Brr, xD, xD1, a, T$, T1$, TT$, s%, n%, m%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range("a1:b" & [a65536].End(3).Row + 1)
ReDim Brr(1 To UBound(Arr), 1 To 2)
For i = 2 To UBound(Arr)
    T = Arr(i, 1)
    If i < UBound(Arr) Then T1 = Arr(i + 1, 1)
    If T = T1 Then
        xD(Arr(i, 1)) = xD(Arr(i, 1)) & "|" & Arr(i, 2)
    Else
        xD(Arr(i, 1)) = xD(Arr(i, 1)) & "|" & Arr(i, 2)
        For ii = 2 To UBound(Arr)
            TT = Arr(ii, 1)
            If TT <> T Then: xD1(Arr(ii, 2)) = ""
        Next
            a = Split(xD(T), "|")
            For j = 1 To UBound(a)
                s = a(j)
                If xD1.Exists(s) Then: n = n + 1
            Next
            m = m + 1: Brr(m, 1) = T: Brr(m, 2) = n
            n = 0: xD.RemoveAll: xD1.RemoveAll
    End If
Next
If m > 0 Then Range("d1").Resize(m, 2) = Brr
End Sub

陈俊超

sam-wang 发表于 2022-1-7 14:10
請測試看看，謝謝
Sub test()
Dim Arr, Brr, xD, xD1, a, T$, T1$, TT$, s%, n%, m%

请问能不能点击按钮后，判断出每个人与其余人的数据重复次数，表格显示，类似这样

sam-wang

陈俊超 发表于 2022-1-7 14:33
请问能不能点击按钮后，判断出每个人与其余人的数据重复次数，表格显示，类似这样

請測試看看，謝謝

陈俊超

好的，我试一下

林木水

1. Dim brr(1 To 10000, 1 To 1)
   
2. Dim k As Integer
   
3. Sub text()
   
4. Dim d As New Dictionary
   
5. Dim d1 As New Dictionary
   
6. Dim d2 As New Dictionary
   
7. Dim i As Integer
   
8. For i = 2 To Range("a65536").End(xlUp).Row
   
9.     d(Cells(i, 1).Value) = d(Cells(i, 1).Value) & "、" & Cells(i, 2).Value
   
10.     If InStr(d(Cells(i, 1).Value), "、") = 1 Then d(Cells(i, 1).Value) = Mid(d(Cells(i, 1).Value), 2, Len(d(Cells(i, 1).Value)))
    
11. Next i
    
12. Range("c:z") = ""
    
13. Range("d1").Resize(d.Count) = Application.Transpose(d.Keys)
    
14. Range("c1").Resize(d.Count) = Application.Transpose(d.Items)
    
15. Range("e1").Value = "对应情况"
    
16. Range("f1").Value = "重复数值"
    
17. Range("g1").Value = "重复个数"
    
18. Erase brr
    
19. Dim arr
    
20. arr = d.Keys
    
21. k = 0
    
22. zuhe arr, 0, "", 0
    
23. Range("e2").Resize(k) = brr
    
24. Dim a, b  'a代表对应1，b代表对应2
    
25. Dim arr1, arr2 '存2个人vs所有的数值
    
26. Dim m As Integer, n As Integer '对照2个人数值用来循环，找出相同
    
27. Dim k1 As Integer '存重复数字的个数
    
28. ReDim crr(1 To k, 1 To 2)
    
29.   For i = 1 To k
    
30.     a = VBA.Split(brr(i, 1), "VS")(0)
    
31.     b = VBA.Split(brr(i, 1), "VS")(1)
    
32.     If InStr(d(a), "、") = 0 Then
    
33.          arr1 = Array(d(a))
    
34.     Else
    
35.         arr1 = VBA.Split(d(a), "、")
    
36.     End If
    
37.     If InStr(d(b), "、") = 0 Then
    
38.         arr2 = Array(d(b))
    
39.     Else
    
40.         arr2 = VBA.Split(d(b), "、")
    
41.     End If
    
42.     '..................去重
    
43.     For m = 0 To UBound(arr1)
    
44.         d1(arr1(m)) = arr1(m)
    
45.     Next m
    
46.     For n = 0 To UBound(arr2)
    
47.         d2(arr2(n)) = arr2(n)
    
48.     Next n
    
49.     arr1 = d1.Keys
    
50.     arr2 = d2.Keys
    
51.     '....................
    
52.         For m = 0 To UBound(arr1)
    
53.             For n = 0 To UBound(arr2)
    
54.                 If arr1(m) = arr2(n) Then
    
55.                     k1 = k1 + 1
    
56.                     crr(i, 1) = crr(i, 1) & "、" & arr1(m)
    
57.                     If InStr(crr(i, 1), "、") = 1 Then crr(i, 1) = Mid(crr(i, 1), 2, Len(crr(i, 1)) - 1)
    
58.                     Exit For
    
59.                 End If
    
60.             Next n
    
61.         Next m
    
62.         crr(i, 2) = k1
    
63.         k1 = 0
    
64.         Set d1 = Nothing: Set d2 = Nothing  '重新加载字典去重
    
65.   Next i
    
66.   Range("f2").Resize(k, 2) = crr
    
67. End Sub
    
68. Sub zuhe(arr, x, sr, y)
    
69. If y = 2 Then
    
70.     k = k + 1
    
71.     brr(k, 1) = Mid(sr, 3, Len(sr))
    
72.     Exit Sub
    
73. End If
    
74.     If x <= UBound(arr) Then
    
75.         zuhe arr, x + 1, sr & "VS" & arr(x), y + 1
    
76.         zuhe arr, x + 1, sr, y
    
77.     End If
    
78. End Sub

复制代码

思路：
1.去重名字
2.根据名字把所有数值重组成一串字符串
3.把每个人的数值拆分成一个数组，并去重
4.递归法把所有VS情况展示出来，递归法如果不会可以去针对性的去看下视频，这个方法抓取所有组合情况的时候非常好用
5.根据每个人的去重后的数值进行循环遍历比较，如果相同那么存入crr的第一列，并且以k1计数重复个数，最后存入crr第二列
6.最后输出结果crr
7.见附件

特别注意一点：
字典需要引用，不能用调用的，否则会出错，目前我还没找到原因。

林木水

1. Dim brr(1 To 10000, 1 To 1)
   
2. Dim k As Integer
   
3. Sub text()
   
4. Dim d As Object
   
5. Dim d1 As Object
   
6. Dim d2 As Object
   
7. Set d = CreateObject("scripting.dictionary")
   
8. Set d1 = CreateObject("scripting.dictionary")
   
9. Set d2 = CreateObject("scripting.dictionary")
   
10. 'Dim d As New Dictionary
    
11. 'Dim d1 As New Dictionary
    
12. 'Dim d2 As New Dictionary
    
13. Dim i As Integer
    
14. For i = 2 To Range("a65536").End(xlUp).Row
    
15.     d(Cells(i, 1).Value) = d(Cells(i, 1).Value) & "、" & Cells(i, 2).Value
    
16.     If InStr(d(Cells(i, 1).Value), "、") = 1 Then d(Cells(i, 1).Value) = Mid(d(Cells(i, 1).Value), 2, Len(d(Cells(i, 1).Value)))
    
17. Next i
    
18. Range("c:z") = ""
    
19. Range("d1").Resize(d.Count) = Application.Transpose(d.Keys)
    
20. Range("c1").Resize(d.Count) = Application.Transpose(d.Items)
    
21. Range("e1").Value = "对应情况"
    
22. Range("f1").Value = "重复数值"
    
23. Range("g1").Value = "重复个数"
    
24. Erase brr
    
25. Dim arr
    
26. arr = d.Keys
    
27. k = 0
    
28. zuhe arr, 0, "", 0
    
29. Range("e2").Resize(k) = brr
    
30. Dim a, b  'a代表对应1，b代表对应2
    
31. Dim arr1, arr2 '存2个人vs所有的数值
    
32. Dim m As Integer, n As Integer '对照2个人数值用来循环，找出相同
    
33. Dim k1 As Integer '存重复数字的个数
    
34. ReDim crr(1 To k, 1 To 2)
    
35.   For i = 1 To k
    
36.     a = VBA.Split(brr(i, 1), "VS")(0)
    
37.     b = VBA.Split(brr(i, 1), "VS")(1)
    
38.     If InStr(d(a), "、") = 0 Then
    
39.          arr1 = Array(d(a))
    
40.     Else
    
41.         arr1 = VBA.Split(d(a), "、")
    
42.     End If
    
43.     If InStr(d(b), "、") = 0 Then
    
44.         arr2 = Array(d(b))
    
45.     Else
    
46.         arr2 = VBA.Split(d(b), "、")
    
47.     End If
    
48.     '..................去重
    
49.     For m = 0 To UBound(arr1)
    
50.         d1(arr1(m)) = arr1(m)
    
51.     Next m
    
52.     For n = 0 To UBound(arr2)
    
53.         d2(arr2(n)) = arr2(n)
    
54.     Next n
    
55.     arr1 = d1.Keys
    
56.     arr2 = d2.Keys
    
57.     '....................
    
58.         For m = 0 To UBound(arr1)
    
59.             For n = 0 To UBound(arr2)
    
60.                 If arr1(m) = arr2(n) Then
    
61.                     k1 = k1 + 1
    
62.                     crr(i, 1) = crr(i, 1) & "、" & arr1(m)
    
63.                     If InStr(crr(i, 1), "、") = 1 Then crr(i, 1) = Mid(crr(i, 1), 2, Len(crr(i, 1)) - 1)
    
64.                     Exit For
    
65.                 End If
    
66.             Next n
    
67.         Next m
    
68.         crr(i, 2) = k1
    
69.         k1 = 0
    
70. '        Set d1 = Nothing: Set d2 = Nothing '重新加载字典去重
    
71.         d1.RemoveAll
    
72.         d2.RemoveAll
    
73.   Next i
    
74.   Range("f2").Resize(k, 2) = crr
    
75. End Sub
    
76. Sub zuhe(arr, x, sr, y)
    
77. If y = 2 Then
    
78.     k = k + 1
    
79.     brr(k, 1) = Mid(sr, 3, Len(sr))
    
80.     Exit Sub
    
81. End If
    
82.     If x <= UBound(arr) Then
    
83.         zuhe arr, x + 1, sr & "VS" & arr(x), y + 1
    
84.         zuhe arr, x + 1, sr, y
    
85.     End If
    
86. End Sub
    
87. 
    

复制代码

用这个代码也可以，直接调用，不需要引用，我把set d1=nothing卸载字典改成d1.removeall就不会出错误了。应该是set=nothing的问题造成调用第二次加载字典的时候无效，估计需要重新定义object创建字典才行

ahn

要统计两两重复值，推荐使用字典嵌套方式，代码既简洁又高效。
不要拼接数值为字符串来当作字典键值，否则数据量大了，拼接字符串会慢如蜗牛爬行。