Count unique values of a column of numbers

Question

I want to count how many times a unique number appeared in the "A" column. I have already extracted the unique numbers into the "B" column using:

Range("A1:A999").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1:B999"), Unique:=True

Now I want to count how many times a number appeared in the column "A" and write it column "C"

I thought about something like this:

1. Check if cell value of A1=A,i (i=1) then count = count + 1
2. Store value of A1 (array)
3. Check if cell value of A2 is stored --> yes: count = count + 1, no: jump to next cell for check
4. When Looped over all cells with numbers --> print count in C1
5. Set count = 0
6. Loop this over all cells with numbers

Im sorry if this sounds a bit confusing but I hope you get what i mean.

Answer 1

Use a Dictionary

Option Explicit
Sub CountUnique()
    Dim ws As Worksheet, dict As Object, k
    Dim i As Long, lastrow As Long
   
    Set dict = CreateObject("Scripting.Dictionary")
    Set ws = ActiveSheet
    ws.Range("A1:C1") = Array("Numbers", "Unique Numbers", "Count of Unique Numbers")
   
    With ws
        ' input
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lastrow
            k = Trim(.Cells(i, 1))
            dict(k) = dict(k) + 1
        Next
   
        ' output
        i = 1
        For Each k In dict.keys
            i = i + 1
            .Cells(i, "B") = k
            .Cells(i, "C") = dict(k)
        Next
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range("B2:B" & i), _
            SortOn:=xlSortOnValues, Order:=xlDescending, _
            DataOption:=xlSortNormal
            .SetRange Range("B1:C" & i)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Range("A1").Select
    End With
    
    MsgBox dict.Count & " Unique numbers", vbInformation
End Sub

Answer 2

Count Unique Values

Option Explicit

Sub GetUniqueColumnRangeWithCountTEST()
' Needs 'GetUniqueColumnRangeWithCount'.
    
    Const sfCellAddress As String = "A2"
    Const dfCellAddress As String = "B2"
    
    ' Create a reference to the first cell of the source one-column range.
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim sfCell As Range: Set sfCell = ws.Range(sfCellAddress)
    
    ' Return the unique values and their count in an array.
    Dim Data As Variant: Data = GetUniqueColumnRangeWithCount(sfCell)
    If IsEmpty(Data) Then Exit Sub ' see message in the Immediate window
    
    ' Write the values from the array to the destination two-column range.
    Dim dfCell As Range: Set dfCell = ws.Range(dfCellAddress)
    Dim drg As Range: Set drg = dfCell.Resize(UBound(Data, 1), UBound(Data, 2))
    drg.Value = Data

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values and their count of a one-column range
'               defined by its first cell, in a 2D one-based two-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetUniqueColumnRangeWithCount( _
    ByVal FirstCell As Range) _
As Variant
    Const ProcName As String = "GetUniqueColumnRangeWithCount"
    On Error GoTo ClearError

    If FirstCell Is Nothing Then Exit Function
    
    ' Create a reference to the source one-column range.
    Dim srg As Range
    Dim srCount As Long
    With FirstCell
        Dim scrg As Range: Set scrg = .Resize(.Worksheet.Rows.Count - .Row + 1)
        Dim slCell As Range
        Set slCell = scrg.Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then Exit Function
        srCount = slCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With
        
    ' Write the values from the source one-column range to the Source Array.
    Dim sData As Variant
    If srCount = 1 Then ' one cell
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else ' multiple cells
        sData = srg.Value
    End If
    
    ' Write the values from the source array to the unique dictionary.
    Dim uDict As Object: Set uDict = CreateObject("Scripting.Dictionary")
    uDict.CompareMode = vbTextCompare
    Dim uKey As Variant
    Dim sr As Long
    For sr = 1 To srCount
        uKey = sData(sr, 1)
        If Not IsError(uKey) Then ' not an error value
            If Not IsEmpty(uKey) Then ' not empty
                uDict(uKey) = uDict(uKey) + 1 ' count
            End If
        End If
    Next sr
    Dim drCount As Long: drCount = uDict.Count
    If drCount = 0 Then Exit Function ' only empty or error values
    Erase sData ' since the relevant data is in the dictionary
            
    ' Write the values from the unique dictionary to the destination array.
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To 2)
    Dim dr As Long
    For Each uKey In uDict.Keys
        dr = dr + 1
        dData(dr, 1) = uKey ' write value
        dData(dr, 2) = uDict(uKey) ' write count
    Next uKey
    
    GetUniqueColumnRangeWithCount = dData

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function