Count and list all values

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