Sub FindDistinctCaseSensitive()
    
    ' Uses late binding
    
    Dim arr As Variant
    Dim Counter As Long
    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 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 = vbBinaryCompare
        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