Public Sub FarbigeZaehlen()
Dim Dict As Variant
Dim WkSh As Worksheet
Dim rBereich As Range
Dim rZelle As Range
Dim lZeile As Long
Set Dict = CreateObject("Scripting.Dictionary") ' Zuordnung an Scripting Dictionary
Set WkSh = ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen!
Set rBereich = WkSh.Range("A1:I20") ' den Bereich an die Gegebenheiten anpassen
For Each rZelle In rBereich
If rZelle.Interior.ColorIndex xlNone Then
Dict(rZelle.Interior.ColorIndex) = Dict(rZelle.Interior.ColorIndex) + 1
End If
Next rZelle
Set rZelle = WkSh.Range("J1") ' die erste Ausgabezelle festlegen
rZelle.Resize(Dict.Count) = WorksheetFunction.Transpose(Dict.Keys)
rZelle.Offset(0, 1).Resize(Dict.Count) = WorksheetFunction.Transpose(Dict.Items)
For lZeile = 1 To WkSh.Cells(Rows.Count, 10).End(xlUp).Row
WkSh.Range("J" & lZeile).Interior.ColorIndex = _
CInt(WkSh.Range("J" & lZeile).Value)
Next lZeile
End Sub