Eri tietoja sisältävien solujen määrän laskeminen, ehdolla...

ihan COUNTIF- funktiolla , laskemalla kirjainten lukumäärä? Tosin noita sinun tuloksiasi sillä ei saa...vaan
A 4
B 1
C 1
D 2
F 1

moduuliin...
tiedot nyt A1:B jotakin
tulos näkyviin F1 alkaen

Sub PoistaTuplat()
Dim cell As Range
Dim Vika As Double
Dim EiTupla As New Collection
On Error GoTo virhe

Vika = Range("A65536").End(xlUp).Row

'kopioidaan tiedot F1 alkaen
Columns("F:G").Clear
Range("A1:B" & Vika).Copy Destination:=Range("F2")

'lajitellaan
Range("F2:G" & Vika).Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("G2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal

'lisätään uniikit arvot kokoelmaan
For Each cell In Range("F2:F" & Vika 1)
If Not IsEmpty(cell) Then
EiTupla.Add cell.Value, CStr(cell.Value & cell.Offset(0, 1).Value)
End If
Next cell
'tyhjennetään alue ja lisätään riviotsikot
Columns("F:G").Clear
Range("F1") = "TULOKSET"
Range("G1") = "MÄÄRÄ"

'täytetään tiedot
'eka kirjain kokoelmasta
Range("F2").Select
ActiveCell = EiTupla(1)

'lisätään loput
For i = 1 To EiTupla.Count
If ActiveCell = EiTupla(i) Then
ActiveCell.Offset(0, 1) = ActiveCell.Offset(0, 1) 1
Else
ActiveCell.Offset(1, 0).Select
ActiveCell = EiTupla(i)
ActiveCell.Offset(0, 1) = ActiveCell.Offset(0, 1) 1
End If
Next
'sarakelevys kohdilleen
Range("F1:G1").EntireColumn.AutoFit
Exit Sub
virhe:
'tänne tullaan, jos arvo oli jo kokoelmassa... jatketaan vaan lisäystä seuraavilla arvolla
Resume Next
End Sub