Hallo,

falls noch keine Lösiung gefunden wurde, kann eventuell diese helfen:

Sub Counter(rngDataSource As Range, NameDestination As String)
    Dim Counter() As Variant
    ' Aufbau: 2. Dimensionen:
    ' 1. Dimension: Inhalt
    ' 2. Dimention: Zähler
    Dim rng As Range
    Dim rngNm As Range, rngNew As Range
    Dim Item As Variant
    Dim bHasData As Boolean
    Dim iPos As Integer
    For Each rng In rngDataSource.Cells
        For Each Item In Split(rng.Value, " ")
            Item = Trim(Item)
            If Not Right(Item, 1) = ":" Then
                CounterItem Counter, Item
                bHasData = True
            End If
        Next
    Next
    
    ' Counter sortieren
    
    SortArray Counter
    
    Set rngNm = ActiveWorkbook.Names(NameDestination).RefersToRange
    
    rngNm.Clear
    If bHasData Then
        For iPos = 0 To UBound(Counter, 2)
            rngNm(iPos + 1, 1) = Counter(0, iPos)
            rngNm(iPos + 1, 2) = Counter(1, iPos)
            'iRow = iRow + 1
        Next
    End If
    
    Set rngNm = rngNm.Cells(1, 1)
    Set rngNew = Range(rngNm, rngNm.Offset(iPos - 1, 1))
    rngNew.Select
    ActiveWorkbook.Names(NameDestination).Delete
    ActiveWorkbook.Names.Add NameDestination, rngNew
End Sub


Sub CounterItem(ByRef data() As Variant, ByVal search As String)
    On Error Resume Next
    Dim iPos As Integer
    Dim hi As Integer
    Dim bFound As Boolean
    hi = UBound(data, 2)
    If Not Err.Number = 0 Then
        Err.Clear
        ReDim data(1, 0)
        data(0, 0) = search
        data(1, 0) = 1
    Else
        bFound = False
        For iPos = 0 To UBound(data, 2)
            If data(0, iPos) = search Then
                data(1, iPos) = data(1, iPos) + 1
                bFound = True
                Exit For
            End If
        Next
        If Not bFound Then
            ' Neuer Eintrag
            ReDim Preserve data(1, UBound(data, 2) + 1)
            data(0, UBound(data, 2)) = search
            data(1, UBound(data, 2)) = 1
        End If
    End If
End Sub

Sub SortArray(ByRef data() As Variant)
    On Error GoTo Err_Handler
    Dim iPos As Integer
    Dim tmp(1) As Variant
    
    iPos = 1
    Do
        If data(0, iPos) < data(0, iPos - 1) Then
            tmp(0) = data(0, iPos)
            tmp(1) = data(1, iPos)
            data(0, iPos) = data(0, iPos - 1)
            data(1, iPos) = data(1, iPos - 1)
            data(0, iPos - 1) = tmp(0)
            data(1, iPos - 1) = tmp(1)
            If iPos > 1 Then iPos = iPos - 1
        Else
            iPos = iPos + 1
        End If
    Loop While iPos <= UBound(data, 2)
Err_Exit:
    Exit Sub
Err_Handler:
    Err.Clear
    GoTo Err_Exit
End Sub

Die Liste wird durch folgenden Aufruf erstellt:

Counter Daten, [Name-Zielliste]

"Daten" ist ein Bereich in dem die zu zählenden Einträge sich befinden

"Name-Zielleiste" ist ein die BEzeichnung  eines Namen-Eintrags.

Der angegebene Namens-Eintrag muss bereits definiert worden sein.

LG, BigBen