Count Unique Objects in a Range

Sub UniqueReport()
 
Application.ScreenUpdating = True
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant
 
varray = Application.InputBox(prompt:="Input your range", Type:=8)
 
'Generate unique list and count
For Each element In varray
    If dict.exists(element) Then
        dict.Item(element) = dict.Item(element) + 1
    Else
        dict.Add element, 1
    End If
Next
 
'Paste report somewhere
Sheet2.Range("A1").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.keys)
Sheet2.Range("B1").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.items)
 
Application.ScreenUpdating = True
End Sub
Posted in VB