用VBA实现查找重复项

Set oDic = CreateObject("Scripting.Dictionary") '

With Sheet1    lRow = .[a65536].End(xlUp).Row    arrRng = .Range("a2:a" & lRow)    ReDim arr(1 To lRow)    For i = LBound(arrRng) To UBound(arrRng)        On Error Resume Next        If arrRng(i, 1) "" Then            oDic.Add arrRng(i, 1), m + 1            If Err.Number = 0 Then                m = m + 1                arr(i) = 1            Else                s = oDic(arrRng(i, 1))                arr(s) = arr(s) + 1                For j = s + 1 To i                    If arrRng(j, 1) = arrRng(i, 1) Then arr(j) = arr(s)                Next j            End If        End If        Err.Clear    Next i    .[b2].Resize(lRow, 1) = Application.Transpose(arr)End With

Set oDic = NothingEnd Sub