Sub es()
Dim c As Variant, m As Object
Application.ScreenUpdating = False
Set m = CreateObject("Scripting.Dictionary")
For Each c In Range("a2", Cells(Rows.Count, "a").End(xlUp))
m(c.Value) = IIf(m.Exists(c.Value), m(c.Value) + 1, 1)
Next c
Range("a2", Cells(Rows.Count, "a").End(xlUp)).ClearContents
[a2].Resize(m.Count, 1) = Application.Transpose(m.keys)
End Sub