Hopefully, this will get you a really good head start. This will create a list of unique values and FREQUENCY, in turn, your top 10 values
Option Explicit
Sub UniqueItems()
' This will display unique items using Column A
' The big difference of this routine is that it is using Dictionary
Dim myArray As Variant
Dim dDictionary As Object
Dim vItem As Variant
Dim Index As Long
Dim NewSheet As Worksheet
Dim sOutput As String
' you can use RANGE to assign to the array
'
' myArray = Range ("B2:B" & LastRow)
'
' or
myArray = ActiveSheet.[a1].Resize(ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
If IsEmptyArray(myArray) Then
MsgBox "You have nothing in Column A", vbCritical, "Nothing in Column A"
Else
Set dDictionary = CreateObject("scripting.dictionary")
For Index = 1 To UBound(myArray)
dDictionary(myArray(Index, 1)) = dDictionary(myArray(Index, 1)) + 1
Next
If SheetExists("Unique List") Then
Application.DisplayAlerts = False
Worksheets("Unique List").Delete
Application.DisplayAlerts = True
End If
Set NewSheet = Worksheets.Add
NewSheet.Name = "Unique List"
NewSheet.Select
With NewSheet
.[A1:B1] = Split("Item Frequency", " ")
.[A2].Resize(dDictionary.Count) = Application.Transpose(dDictionary.Keys)
.[B2].Resize(dDictionary.Count) = Application.Transpose(dDictionary.Items)
End With
' Output onto screen
With dDictionary
For Each vItem In .Keys
sOutput = sOutput & vbLf & vItem & " (" & .Item(vItem) & ")"
Next
End With
Set dDictionary = Nothing
End If
End Sub
Public Function IsEmptyArray(InputArray As Variant) As Boolean
On Error GoTo ErrHandler:
IsEmptyArray = Not (UBound(InputArray) >= 0)
Exit Function
ErrHandler:
IsEmptyArray = True
On Error GoTo 0
End Function
Function SheetExists(sName As String, Optional oWb As Workbook) As Boolean
'Returns true if sheet exists in the specified workbook.
'If no workbook supplied, the activeworkbook is used.
If oWb Is Nothing Then
Set oWb = ActiveWorkbook
End If
On Error Resume Next
SheetExists = CBool(Not oWb.Sheets(sName) Is Nothing)
On Error GoTo 0
End Function