Dim c As Range, m As Object
Sub es()
Application.ScreenUpdating = False
Set m = CreateObject("Scripting.Dictionary")
For Each c In Range("a2", Cells(Rows.Count, "a").End(xlUp))
m(c.Value) = m(c.Value) + 1
Next c
[B2].Resize(m.Count, 1) = Application.Transpose(m.keys)
[c2].Resize(m.Count, 1) = Application.Transpose(m.Items)
'Set m = Nothing
End Sub
Sub est()
On Error Resume Next
[e2].Resize(m.Count, 1) = Application.Transpose(m.keys)
[f2].Resize(m.Count, 1) = Application.Transpose(m.Items)
End Sub