Sub FindDistinct()
    
    ' Uses late binding
    
    Dim arr As Variant
    Dim Counter As Long
    Dim coll As Collection
    Dim dic As Object
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    With ThisWorkbook.Worksheets("Data")
        
        ' Clear existing results, if applicable
        
        .Range("b1").Resize(1, .Columns.Count - 1).EntireColumn.Delete
        
        ' Transfer contents of Column A to array for processing
        
        arr = .Range("a2", .Cells(.Rows.Count, "a")).Value
        
        ' Create a Collection
        
        Set coll = New Collection
        
        ' Loop through array and try to add each item in turn to the Collection.  Adding an item
        ' where the key already exists generates an error; On Error Resume Next ignores the error
        ' (and thus the duplicate item does not get added to the Collection)
        
        On Error Resume Next
        For Counter = 1 To UBound(arr, 1)
            coll.Add arr(Counter, 1), arr(Counter, 1)
        Next
        On Error GoTo 0
        
        ' Write results to the worksheet and destroy Collection
        
        .Range("c1") = "Collection"
        For Counter = 1 To coll.Count
            .Cells(Counter + 1, "c") = coll(Counter)
        Next
        Set coll = Nothing
        .Range("c1").Sort Key1:=.Range("c1"), Order1:=xlAscending, Header:=xlYes
        
        ' Create Dictionary object and loop through array of values.  For each value, treat it as
        ' both an item and a key, and set the item value using that key.  Where the key already
        ' existed, it will simply overwrite the existing item (albeit with the same value); where
        ' the key did not already exist, it will create the item/key pair.  CompareMode set to
        ' make Dictionary case insensitive.
        
        Set dic = CreateObject("Scripting.Dictionary")
        dic.CompareMode = vbTextCompare
        For Counter = 1 To UBound(arr, 1)
            dic.Item(arr(Counter, 1)) = arr(Counter, 1)
        Next
        
        ' Write results to worksheet.  First, create an array of all items (we could also have used
        ' the keys here, as they are the same), then write the transposed array to the worksheet (to
        ' force the values down a column instead of across a row)
        
        .Range("e1") = "Dictionary"
        arr = dic.Items
        .Range("e2").Resize(dic.Count, 1).Value = Application.Transpose(arr)
        Set dic = Nothing
        .Range("e1").Sort Key1:=.Range("e1"), Order1:=xlAscending, Header:=xlYes
        
        ' Resize columns as needed
        
        .Columns.AutoFit
    End With
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox "Done"
    
End Sub

Select all