TOP10 Duplicates

Voisiko lähteä ratkomaan subtotalilla?

https://www.extendoffice.com/documents/excel/4086-excel-sort-after-subtotal.html

Jos tämä on vain ainutkertainen tapahtuma niin helpoiten käy että kopioit tämän alkuperäisen listan ja liität sen johonkin viereiseen sarakkeeseen ja valitset sitten Tiedot-välilehden "Poista kaksoiskappaleet". Kirjoita ensimmäisen kohdalle kaava (jos tuo alkup. olisi vaikka A-sarakkeella)
=LASKE.A(A:A) ja kopioi kaava kaikkiin. Lajittele arvot sitten nousevaan järjestykseen.

Option Explicit
Dim cl As Range
Dim cainoa As Collection
Dim i As Long
Dim uList() As Variant
Dim ws As Worksheet
Dim TäytäLista As Variant

Sub Uniikit()
On Error Resume Next
Set cainoa = New Collection
'nyt A-sarake muuta tarvittaessa
For Each cl In Range("A1:A7")
If cl.Value <> "" Then
cainoa.Add cl.Value, CStr(cl.Value)
End If
Next cl
TäytäLista = ""
If cainoa.Count > 0 Then
ReDim uList(1 To cainoa.Count)
For i = 1 To cainoa.Count
uList(i) = cainoa(i)
Next i
TäytäLista = Application.WorksheetFunction.Transpose(uList)
End If
'nyt C- ja D-sarakkeesen tiedot, muuta sopivaksi
Range("C:C") = ""
Range("C1").Resize(cainoa.Count) = TäytäLista
For Each cl In Range("C1").Resize(cainoa.Count)
cl.Offset(0, 1) = Application.WorksheetFunction.CountIf(Range("A1:A7"), cl)
Next
Range("C1").Select
End Sub