try

Code:
--------------------

Sub test()
Dim dic As Object, x, y, a, i
Set dic = CreateObject("Scripting.Dictionary")
a = Range("a1", Range("a65536").End(xlUp)).Value
For i = LBound(a, 1) To UBound(a, 1)
If Not IsEmpty(a(i, 1)) And Not dic.exists(a(i, 1)) Then
dic.Add a(i, 1), 1
Else
dic(a(i, 1)) = Val(dic(a(i, 1))) + 1
End If
Next
If dic.Count < 1 Then Exit Sub
x = dic.keys: y = dic.items
With Range("c1")
.CurrentRegion.ClearContents
.Resize(UBound(x) + 1).Value = Application.Transpose(x)
.Offset(, 1).Resize(UBound(y) + 1).Value = Application.Transpose(y)
End With
Set dic = Nothing: Erase a, x, y
End Sub

--------------------


--
jindon
------------------------------------------------------------------------
jindon's Profile: http://www.excelforum.com/member.php...o&userid=13135
View this thread: http://www.excelforum.com/showthread...hreadid=387584