去重

Sub 去重()
Application.ScreenUpdating = False
Dim r As Range, arr
With CreateObject("scripting.dictionary")
a = Cells(2000, 9).End(xlUp).Row
    For k = 9 To 10
        For Each r In Range(Cells(4, k), Cells(a, k))
            If Not .Exists(r.Value) And r.Value <> "" Then .Add r.Value, Nothing
        Next
            Cells(4, k + 4).Resize(.Count, 1) = Application.WorksheetFunction.Transpose(.Keys)
            .RemoveAll
    Next
End With
Application.ScreenUpdating = True
End Sub