Generate a Cell Count Table

Try this

Option Explicit

Sub test()
    Dim a, e
    a = Sheets("sheet1").UsedRange.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMOde = 1
        .Item("Item") = "Count"
        For Each e In a
            If e <> "" Then .Item(e) = .Item(e) + 1
        Next
        a = Application.Transpose(Array(.keys, .items))
    End With
    With Sheets("sheet2")
        .Cells.ClearContents
        .Cells(1).Resize(UBound(a, 1), 2).Value = a
    End With
End Sub