Sub es()
Dim t(), i As Long, m As Object
Set m = CreateObject("Scripting.Dictionary")
t = Range("a2:a" & Cells(Rows.Count, 1).End(3).Row)
For i = 1 To UBound(t)
m(t(i, 1)) = m(t(i, 1)) + 1
Next i
[e4].Resize(m.Count) = Application.Transpose(m.keys)
[f4].Resize(m.Count) = Application.Transpose(m.Items)
End Sub