Count and list all values - excel

Question

I'm trying to loop through cells of a specific column, find new values in those cells, count how many times a specific value is found and return the values along with the number of times it appeared.
The values I am looking at are all text.
Something like this:
This is the code I found. I get a compile error
ByRef arguement type mismatch
Function findValues() As Scripting.Dictionary
Dim cellValue
Dim dict As New Scripting.Dictionary
For iRow = 2 To g_totalRow
cellValue = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
If dict.Exists(cellValue) Then
dict.Item(cellValue) = dict.Item(cellValue) + 1
Else
dict.Item(cellValue) = 1
End If
Next iRow
Set findValues = dict
End Function
Sub displayValues(dict As Scripting.Dictionary)
Dim i
Dim value
Dim valueCount
For i = 1 To dict.count
valueCount = dict.Items(i)
value = dict.Keys(i)
ActiveWorkbook.Sheets(sheetName).Cells(i, 3).Text = value
ActiveWorkbook.Sheets(sheetName).Cells(i, 4).Text = valueCount
Next i
End Sub
Sub RunAndDisplay()
Dim dict
Set dict = findValues
displayValues dict
End Sub

Answer 1

Write Unique Column Values With Count
Here's a version more customized to your actual case.
Adjust the values in the constants section.
You only need to replace the worksheet names (sName and dName) with your actual worksheet (tab) name(s).
You can easily write the result to another worksheet by changing the dName constant.
There is no need for a reference to the Microsoft Scripting Runtime so remove it from the workbook (VBE>Tools>References).
Option Explicit
Sub WriteUniqueWithCount()
Const ProcName As String = "WriteUniqueWithCount"
On Error GoTo ClearError
' Source
Const sName As String = "Sheet1"
Const sfCellAddress As String = "A2"
' Destination
Const dName As String = "Sheet1"
Const dfCellAddress As String = "C2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim sfCell As Range: Set sfCell = sws.Range(sfCellAddress)
Dim scrg As Range: Set scrg = RefColumn(sfCell)
If scrg Is Nothing Then Exit Sub ' no data in column
Dim Data As Variant: Data = GetRange(scrg)
Dim dict As Object: Set dict = DictColumnCount(Data)
If dict Is Nothing Then Exit Sub ' only error values and blanks
Data = GetDict(dict) ' 2 columns: keys (values) and items (count)
Set dict = Nothing
Dim rCount As Long: rCount = UBound(Data, 1)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
If dws.AutoFilterMode Then dws.AutoFilterMode = False
Dim dfCell As Range: Set dfCell = dws.Range(dfCellAddress)
With dfCell.Resize(, 2) ' first row
.Resize(rCount).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
End With
MsgBox "Unique values and their count are written.", vbInformation, ProcName
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefColumn"
On Error GoTo ClearError
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values and their count from a column
' ('ColumnIndex') of a 2D array ('Data') in the keys and items
' of a dictionary.
' Remarks: Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictColumnCount( _
ByVal Data As Variant, _
Optional ByVal ColumnIndex As Variant) _
As Object
Const ProcName As String = "DictColumnCount"
On Error GoTo ClearError
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim c As Long
If IsMissing(ColumnIndex) Then
c = LBound(Data, 2)
Else
c = CLng(ColumnIndex)
End If
Dim Key As Variant
Dim r As Long
For r = LBound(Data, 1) To UBound(Data, 1)
Key = Data(r, c)
If Not IsError(Key) Then
If Len(CStr(Key)) > 0 Then
dict(Key) = dict(Key) + 1
End If
End If
Next r
If dict.Count = 0 Then Exit Function
Set DictColumnCount = dict
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values from a dictionary in a 2D one-based array.
' Remarks: F, F, F - returns the keys and items in two columns.
' F, F, T - returns the items and keys in two columns.
' F, T, F - returns the keys in a column.
' F, T, T - returns the items in a column.
' T, F, F - returns the keys and items in two rows.
' T, F, T - returns the items and keys in two rows.
' T, T, F - returns the keys in a row.
' T, T, T - returns the items in a row.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetDict( _
ByVal sDict As Object, _
Optional ByVal Horizontal As Boolean = False, _
Optional ByVal FirstOnly As Boolean = False, _
Optional ByVal Flip As Boolean = False) _
As Variant
Const ProcName As String = "GetDict"
On Error GoTo ClearError
Dim sCount As Long: sCount = sDict.Count
If sCount = 0 Then Exit Function
Dim Data As Variant
Dim Key As Variant
Dim i As Long
If Not Horizontal Then
If Not FirstOnly Then
ReDim Data(1 To sCount, 1 To 2)
If Not Flip Then
For Each Key In sDict.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = sDict(Key)
Next Key
Else
For Each Key In sDict.Keys
i = i + 1
Data(i, 1) = sDict(Key)
Data(i, 2) = Key
Next Key
End If
Else
ReDim Data(1 To sCount, 1 To 1)
If Not Flip Then
For Each Key In sDict.Keys
i = i + 1
Data(i, 1) = Key
Next Key
Else
For Each Key In sDict.Keys
i = i + 1
Data(i, 1) = sDict(Key)
Next Key
End If
End If
Else
If Not FirstOnly Then
ReDim Data(1 To 2, 1 To sCount)
If Not Flip Then
For Each Key In sDict.Keys
i = i + 1
Data(1, i) = Key
Data(2, i) = sDict(Key)
Next Key
Else
For Each Key In sDict.Keys
i = i + 1
Data(1, i) = sDict(Key)
Data(2, i) = Key
Next Key
End If
Else
ReDim Data(1 To 1, 1 To sCount)
If Not Flip Then
For Each Key In sDict.Keys
i = i + 1
Data(1, i) = Key
Next Key
Else
For Each Key In sDict.Keys
i = i + 1
Data(1, i) = sDict(Key)
Next Key
End If
End If
End If
GetDict = Data
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function