字典去重法
:
Sub wanao()
Dim dic As Object, i As Long, arr, a, b As Integer
Set dic = CreateObject("Scripting.Dictionary")
arr = Range("b1:b" & Cells(Rows.Count, "b").End(xlUp).Row)
For i = 1 To UBound(arr, 1)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
For Each a In dic
If dic(a) > 1 Then
b = b + 1
Cells(b, "c") = a
End If
Next
End Sub