Sub Lista()

Dim Cella As Range
Dim Vettore()
Dim Testo
Dim Indice
Dim Trovato

ReDim Vettore(2, 1)
Vettore(1, 1) = Range("C2")
Vettore(2, 1) = 1

For Each Cella In Range("C3", Range("C3").End(xlDown))
    Trovato = False
    For Indice = 1 To UBound(Vettore, 2)
        If Cella = Vettore(1, Indice) Then
            Vettore(2, Indice) = Vettore(2, Indice) + 1
            Trovato = True
            Exit For
        End If
    Next Indice
    If Not Trovato Then
        ReDim Preserve Vettore(2, UBound(Vettore, 2) + 1)
            Vettore(1, UBound(Vettore, 2)) = Cella
            Vettore(2, UBound(Vettore, 2)) = 1
    End If
Next Cella

Testo = ""
For Indice = 1 To UBound(Vettore, 2)
Testo = Testo & Vettore(1, Indice) & ": " & Vettore(2, Indice) & vbCrLf
Next Indice
MsgBox Testo
End Sub
​

Sub unici()
Columns("N:N").ClearContents
    Set rngData = Range("C1", Range("C2").End(xlDown))
    rngData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(2, "N"), Unique:=True
    Range(Range("N2").Offset(1, 1), Range("N2").End(xlDown).Offset(0, 1)).FormulaR1C1 = "=COUNTIF(" & rngData.Address(1, 1, xlR1C1) & ",RC[-1])"
End Sub