Generate a Cell Count Table

Hello There,
I have a big excel sheet with data in many cells across rows and columns:
X Y Z
X X Z
T V V
Z V V

What i wanted to do is generate a list of cells with count as

V 4
Z 3
X 3
T 1
Y 1

Can someone point me in the right direction, thanks.

Let your range of data is in sheet1
the results will end in sheet2

mind the starting row in sheet1

Sub count()

Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("sheet2")

r = 4
r2 = 3
While sh1.Cells(r, 1) <> ""
c = 1
While sh1.Cells(r, c) <> ""
ky = sh1.Cells(r, c)
Set x = sh2.Range("A:A").Find(ky, LookIn:=xlValues)
If x Is Nothing Then
sh2.Cells(r2, 1) = ky
rx = r2
r2 = r2 + 1
Else
rx = x.Row
End If
sh2.Cells(rx, 2) = sh2.Cells(rx, 2) + 1
c = c + 1
Wend
r = r + 1
Wend

End Sub

Dear ginjack:

The inner loop scoops data until there is none so there can be variable number of columns

look at sample with variable number of columns

Thanks RCM, i tried. script works as expected, but the values are incorrect.
For example, if i search for the same keyword in excel, i get only 2 results
but the script counted it as 79 results.
I thought maybe script is picking up entries around it, but no number is near to the result i got by manually testing (2)
Is there something that i am overlooking?

Hi RCM, i have attached my output for sample, please check 1st entry, count shows there are 5, but there are only 2 results in Excel sheet.
i think somewhere, calculation is giving an error

Originally Posted by mikerickson

I think that this will do what you want

Sub test()
    Dim UniqueValues() As String
    Dim SourceRange As Range
    Dim SourceSheet As Worksheet
    Dim DestinationRange As Range
    Dim Pointer As Long, oneCell As Range
    
    Set SourceSheet = Sheet1
    Set DestinationRange = Sheet2.Range("A1")
        
    Set SourceRange = SourceSheet.UsedRange
    ReDim UniqueValues(1 To SourceRange.Cells.Count, 1 To 1)
    
    For Each oneCell In SourceRange
        If IsError(Application.Match(CStr(oneCell.Value), UniqueValues, 0)) Then
            Pointer = Pointer + 1
            UniqueValues(Pointer, 1) = CStr(oneCell.Value)
        End If
    Next oneCell
    
    With DestinationRange.Resize(Pointer, 1)
        .Value = UniqueValues
        .Offset(0, 1).FormulaR1C1 = "=COUNTIF(" & SourceRange.Address(True, True, xlR1C1, True) & ",RC[-1])"
        .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo
    End With
    
End Sub

Thanks Mike, i tried running the script but it keeps crashing my excel, i have about 1million cells of data, and a strong laptop but i guess it isn't able to process it.
RCM's solution works, but is giving me incorrect number counts

Here is the sub. It works on the sample. could you send a larger sample?

Sub count()

Set sh1 = Sheets("sheet1")
Set sh2 = Sheets("sheet2")
sh2.Select
Cells.ClearContents
r = 4
r2 = 3
While sh1.Cells(r, 1) <> ""
c = 1
While sh1.Cells(r, c) <> ""
ky = sh1.Cells(r, c)
Set x = sh2.Range("A:A").Find(ky, LookIn:=xlValues)
If x Is Nothing Then
sh2.Cells(r2, 1) = ky
rx = r2
r2 = r2 + 1
Else
rx = x.Row
End If
sh2.Cells(rx, 2) = sh2.Cells(rx, 2) + 1
c = c + 1
Wend
r = r + 1
Wend

End Sub

Ok I improved it and came up with this version

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

Originally Posted by jindon

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

Thanks Jindon,
this worked perfectly, and it did it in about 3 seconds.
The other script codes were taking about 30mins + and still crashing.