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
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen