EXCEL VBA实现重复字段出现次数并列显示

Sub dotest()   '
    Dim arr, d
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet2")
        r = .Cells(.Rows.Count, "a").End(xlUp).Row
        arr = .[a1].Resize(r, 1)
    End With
    For i = 2 To UBound(arr)
        s = arr(i, 1)
        d(s) = d(s) + 1
    Next
    With Sheets("Sheet1")
        r = .Cells(.Rows.Count, "a").End(xlUp).Row
        arr = .[a1].Resize(r, 2)
        For i = 2 To UBound(arr)
            s = arr(i, 1)
            If d.exists(s) Then
                If d(s) > 1 Then
                    arr(i, 2) = d(s)
                Else
                    arr(i, 2) = ""
                End If
            End If
        Next
        .[a1].Resize(r, 2) = arr
    End With
    Set d = Nothing
    Application.ScreenUpdating = True
    MsgBox "OK！"
End Sub