Sub qqq()
Dim Uniq As New Collection, LastRow As Long, i As Long, a()
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
a = Range(Cells(2, 1), Cells(LastRow, 1)).Value
For i = 1 To UBound(a, 1)
On Error Resume Next
Uniq.Add a(i, 1), CStr(a(i, 1))
Next

For i = 1 To Uniq.Count
Cells(i + 1, 3) = Uniq.Item(i)
Next

End Sub

Sub sdssd()
     Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
     Dim cell As Range
     For Each cell In [A2:A101]
         dic(cell.Value) = dic(cell.Value) + 1
     Next
     [C2].Resize(UBound(dic.keys) + 1) = Application.Transpose(dic.keys)
End Sub

Option Explicit
Sub getunique()
      Const rr = 2 ^ 16
      On Error GoTo getunique_Error
      Dim AL:  Set AL = CreateObject("System.Collections.ArrayList")
      Dim AL1: Set AL1 = CreateObject("System.Collections.ArrayList")
      Dim cell As Range, i%, n&, m&
      With Application
          .ScreenUpdating = 0: .EnableEvents = 0
          For Each cell In [A2:A101]
              If Not AL.contains(cell.Value) Then AL.Add cell.Value
          Next
          'AL.Sort ' сортировка по возрастанию
          'AL.Sort: AL.Reverse 'сортировка по убыванию
          Do
              n = Application.Min(rr, AL.Count - i * rr)
              Set AL1 = AL.getrange(i * rr - IIf(i, 1, 0), n)
              With [C2].Offset(i*rr).Resize(n)
                  .Formula = Application.Transpose(AL1.Toarray)
                  m = m + .Count
              End With
              i = i + 1
          Loop Until m = AL.Count
          Set AL = Nothing: Set AL1 = AL
getunique_Error:
          .ScreenUpdating = 1: .EnableEvents = 1
      End With
      If Err.Number Then MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub getunique"
End Sub

Resize(dic.count)