求助大神，判断有无重复

刀羊

yjh_27 发表于 2019-3-3 05:33
参见附件。

排序法挺好，
雷同法对包含关系判断有误

sayhi95

1. Sub test()
   
2.     Dim arr, temparr()
   
3.     arr = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Value
   
4.     ReDim temparr(1 To UBound(arr), 1 To 1)
   
5.     Set dic1 = CreateObject("Scripting.Dictionary")
   
6.     Set dic2 = CreateObject("Scripting.Dictionary")
   
7.     For i = 1 To UBound(arr)
   
8.         t0 = Split(arr(i, 1), " ")
   
9.         For Each tt0 In t0
   
10.             dic1(tt0) = ""
    
11.         Next
    
12.         For j = 1 To UBound(arr)
    
13.             If j <> i Then
    
14.                 t1 = Split(arr(j, 1), " ")
    
15.                 For Each tt1 In t1
    
16.                     dic2(tt1) = ""
    
17.                 Next
    
18.             Else
    
19.                 GoTo flag1
    
20.             End If
    
21.             For Each k In dic1
    
22.                 If dic2.exists(k) Then
    
23.                     n = n + 1
    
24.                 End If
    
25.             Next
    
26.             If n = dic1.Count And UBound(t0) = UBound(t1) Then
    
27.                 temparr(i, 1) = "重复"
    
28.                 GoTo flag2
    
29.             End If
    
30.             dic2.RemoveAll: n = 0
    
31. flag1:                    Next
    
32. flag2:      dic1.RemoveAll: j = 1: n = 0: Next
    
33.      Range("B1").Resize(UBound(arr), 1) = temparr
    
34. End Sub

复制代码

VBA解法

Datous

就是拍一下序，后面是排序方法。

1. 
   
2. Sub TagRepetition()
   
3. Dim vntData, strRpt() As String, lngCount As Long
   
4. Dim lngNoRpt() As Long, blnRpt As Boolean
   
5. Dim A, B, N, T
   
6. 
   
7. vntData = Range("A1").Resize(Range("A60000").End(xlUp).Row, 1)
   
8. lngCount = UBound(vntData)
   
9. If lngCount = 1 Then Exit Sub
   
10. ReDim strRpt(1 To lngCount)
    
11. 
    
12. T = Split(vntData(1, 1), " ")
    
13. Call MergeSort(T, LBound(T), UBound(T))
    
14. vntData(1, 1) = Join(T, " ")
    
15. N = 1
    
16. ReDim lngNoRpt(1 To N)
    
17. lngNoRpt(N) = 1
    
18. 
    
19. For A = 2 To lngCount
    
20.     blnRpt = False
    
21.     T = Split(vntData(A, 1), " ")
    
22.     Call MergeSort(T, LBound(T), UBound(T))
    
23.     vntData(A, 1) = Join(T, " ")
    
24.     For B = 1 To N
    
25.         If vntData(A, 1) = vntData(lngNoRpt(B), 1) Then
    
26.             strRpt(A) = "重复"
    
27.             strRpt(lngNoRpt(B)) = "重复"
    
28.             blnRpt = True
    
29.             Exit For
    
30.         End If
    
31.     Next
    
32.     If Not blnRpt Then
    
33.         N = N + 1
    
34.         ReDim Preserve lngNoRpt(1 To N)
    
35.         lngNoRpt(N) = A
    
36.     End If
    
37. Next
    
38. Range("C1").Resize(lngCount, 1) = Application.WorksheetFunction.Transpose(strRpt)
    
39. End Sub

复制代码

1. Sub MergeSort(vntArr, lngLeft As Long, lngRight As Long)
   
2.     Dim lngMid As Long
   
3.     If lngRight > lngLeft Then
   
4.         lngMid = Int((lngLeft + lngRight) / 2)
   
5.         Call MergeSort(vntArr, lngLeft, lngMid)
   
6.         Call MergeSort(vntArr, lngMid + 1, lngRight)
   
7.         Call Merge(vntArr, lngLeft, lngMid, lngRight)
   
8.     End If
   
9. End Sub
   
10. 
    
11. Sub Merge(vntArr, lngL As Long, lngM As Long, lngR As Long)
    
12. Dim vntTmp()
    
13. Dim I As Long, J As Long, K As Long
    
14. 
    
15. I = lngL
    
16. J = lngM + 1
    
17. K = lngL
    
18. ReDim vntTmp(lngL To lngR)
    
19. 
    
20. While I <= lngM And J <= lngR
    
21.     If vntArr(I) <= vntArr(J) Then
    
22.         vntTmp(K) = vntArr(I)
    
23.         K = K + 1
    
24.         I = I + 1
    
25.     Else
    
26.         vntTmp(K) = vntArr(J)
    
27.         K = K + 1
    
28.         J = J + 1
    
29.     End If
    
30. Wend
    
31. 
    
32. While I <= lngM
    
33.     vntTmp(K) = vntArr(I)
    
34.     K = K + 1
    
35.     I = I + 1
    
36. Wend
    
37. 
    
38. While J <= lngR
    
39.     vntTmp(K) = vntArr(J)
    
40.     K = K + 1
    
41.     J = J + 1
    
42. Wend
    
43. 
    
44. For I = lngL To lngR
    
45.     vntArr(I) = vntTmp(I)
    
46. Next
    
47. End Sub

复制代码