Unterschiedliche Farben zählen

[Castor]

He, Uwe,
würdest du auch Zellfarben auf diese Weise zählen…?!

	A	B	C
1	19	13434879	#FFFFCC
2	19	13106680	#F8FDC7
3	19	14811135	#FFFFE1
4	19	12451839	#FFFFBD
5	19	14281213	#FDE9D9
6	19	14408946	#F2DCDB
7	19	14610923	#EBF1DE
8	2	16777215	#FFFFFF
9	2	16117479	#E7EEF5
10	2	15137023	#FFF8E6

Dein Pgm ergäbe ab Xl12/2007 bei vorstehendem Bsp falsch 2 statt richtig 10 Variablen für Farbwerte.
Gruß, Castor

[Kuwer]

Hi Loki,

He, Uwe,
würdest du auch Zellfarben auf diese Weise zählen…?!

genauer geht es natürlich mit Color statt ColorIndex.
Ich bleibe aber bei den Zeichenfarben in einer Zelle:

Sub ZaehleFarben()
 Dim i As Long, colAnzahl As New Collection
 On Error Resume Next
 With ActiveCell
   For i = 1 To Len(.Value)
     colAnzahl.Add .Characters(i, 1).Font.Color, CStr(.Characters(i, 1).Font.Color)
   Next i
 End With
 MsgBox "Es werden " & colAnzahl.Count & " Variablen für die Farben benötigt."
End Sub

Gruß Uwe

[Algor]

Einfache Lösung mittels Schleife

Code:

Sub Farbhäufigkeiten_Zählen()
'Lösung mittels Doppelschleife
Dim a, b, c, i

c = 0
For a = -1 To 56
   For i = 1 To Len(Range("A1"))
   If Range("A1").Characters(i, 1).Font.ColorIndex = a Then c = c + 1
   Next
   If Not c = 0 Then
   b = b + 1
   Debug.Print "ColorIndex: " & a & " Häufigkeit: " & c
   End If
   c = 0
Next

Debug.Print "Anzahl unterschiedliche Farben: " & b
End Sub

[Castor]

Hat es einen besonderen Grund, Algor,
dass du prinzipiell bereits gepostete Lösungen in etwas anderer Form noch einmal wiederholst oder bist du mit Lago identisch? Dann solltest du aber auch meinen Hinweis bzgl .Color  vs .ColorIndex beachten!
Gruß, Castor

[Algor]

@Lieber Castor,

von welchen vielen Lösungen redest du?! Es gibt nur 2, die von Uwe und die von mir! Dein Hinweis mit ColorIndex und Color? Dann versuch mal bei meiner Schleife mit Color (es gibt über 16 Millionen Farben!), statt ColorIndex zu arbeiten.
Meine Lösung kommt schon bei ca. 57 Werten für die möglichen ColorIndex-Werte absolut an ihre Grenzen. Viel Spaß! Ich wollte im Gegensatz zu Uwe eine ganz, ganz einfache Lösung zeigen, die nicht auf einer eingebauten Funktion beruht.  Was meinst du, warum der Uwe so ein Ass in VBA ist? Weil er alle Alternativen kennt, diese in- und auswendig gelernt hat und beherrscht. Das Wissen um Optionen ist für alle Lernprozesse, nicht nur bei VBA essentiell.


Bitte lese nächstes mal den Thread!

[Castor]

Oh, entschuldige, Algor,
dass ich im 1.Moment angenommen hatte, dass dein Programm nur eine Variation derer von snb und Uwe gewesen sei. Es ist natürlich eine eigenständige Arbeit, auf die bspw ich niemals verfallen wäre, denn sie hat durchaus das Potenzial für enorme Laufzeiten, was dem Anwender erlauben könnte zwischendurch nicht nur Kaffee trinken zu gehen, nein, auch zu Mittag zu essen und ggf auch noch einzukaufen, falls er sich im Zeitalter der CorporateIdentity-Farben nicht auf die mehrdeutigen 56 Farbindizes beschränken wollte (der Index für ungefärbt ist übrigens nicht -1 und 0 gibt's nur als Farbwert!).
Es wäre doch wohl viel einfacher und schneller, alle verwendeten Echtfarben in einem 1maligen Textdurchlauf festzustellen, die dabei flfd miteinander und ggf zum Schluss noch insgesamt zu vergleichen (was durch die Verwendung eines Dictionarys bzw einer Collection nicht erforderlich ist!). Und falls mal ein Text 1farbig sein sollte, kann man auch das zuvor feststellen und sich dann das zeichenweise Durchgehen sparen. Letzteres kann man auch für Textabschnitte tun, immer vom Zeichen lt Laufvariable bis zum jeweiligen Textende, was das Ganze noch beschleunigen könnte.
Castor

[Algor]

@Naja, den Unterschied bzw. die Mängel meines Programms zu dem von Uwe hatte ich ja eigentlich schon deutlich erklärt.

Daher nochmal eine Alternative:

Code:

Sub Farbhäufigkeiten_Aller_Buchstaben_Zählen()
ReDim Feld(1 To Len(Range("A1")))

For i = 1 To Len(Range("A1"))
Feld(i) = Range("A1").Characters(i, 1).Font.ColorIndex
Next

a = 0
For i = WorksheetFunction.Min(Feld) To WorksheetFunction.Max(Feld)
If Not UBound(Filter(Feld, i, True, 1)) + 1 = 0 Then
a = a + 1
Debug.Print "ColorIndex " & i & " = " & UBound(Filter(Feld, i, True, 1)) + 1
End If
Next

Debug.Print "Anzahl unterschiedlicher Farben: " & a

End Sub

oder

Code:

Sub Unterschiedliche_Farben_zählen_Alternative3()
Dim vbString As String, vbColor

For i = 1 To Len(Range("A1"))
vbColor = Range("A1").Characters(i, 1).Font.ColorIndex
If InStr(vbString, vbColor) = 0 Then vbString = vbString & vbColor & "#"
Next
Debug.Print "Es befinden sich " & UBound(Split(vbString, "#")) & " unterschiedliche Farben in der Zelle."

End Sub

[Lago]

Hey everybody,
und vielen dank für eure zahlreichen Hilfestellungen. Was ich allerdings nicht verstehe ist den von Fennek und Peter angegebenen Code von SNB
zu dieser Thematik.
Hier nochmal der Code:

Code:

Sub M_snb_Lösung.()
'http://www.office-loesung.de/p/viewtopic.php?f=166&t=685509&hilit=farbe+z%C3%A4hlen

  With CreateObject("Scripting.Dictionary")
    For Each cl In Tabelle1.Cells(1).CurrentRegion
      .Item(cl.Interior.Color) = .Item(cl.Interior.Color) + 1
    Next

    For j = 0 To .Count - 1
       Sheets("Tabelle2").Cells(20 + j, 1).Interior.Color = .keys()(j)
    Next
    Sheets("Tabelle2").Cells(20, 1).Resize(.Count) = Application.Transpose(.items)
 End With
End Sub

Was macht der Code, was kann der Code. Wenn ich den Code durchlaufen lasse passiert nichts.
Könnte jemand ein fachkundiges Beispiel geben? Danke im voraus.

[schauan]

Hallöchen,

der Code geht etwas an Deiner Fragestellung vorbei. Er soll ausgehend von A1 die Schriftfarben der Zellen und nicht die Schriftfarbe einzelner Wörter zählen. Eine "mehrfarbige" Schrift in einer Zelle wird entsprechend nur als eine Farbe gezählt.
Allerdings funktioniert das anscheinend bei mir unter 2016 nicht. Ich bekomme trotz gleicher Formatierung jede Zelle gezählt und nicht jede Farbe. Umfasst meine CurrentRegion 16 Zellen, wird mir 16 ausgegeben, egal, ob in den Zellen was unterschiedlich formatiert ist oder nicht
   

Es werden auch nicht alle Schriftfarben eines Blattes berücksichtigt. Wenn Deine Daten nicht ausgehend von A1 waagerecht, senkrecht oder diagonal zusammenhängen, wird nach diesem "Lückenbereich" nicht weiter gezählt.

Nichts passieren sollte eigentlich nicht. Wenn keine Fehlermeldung kommt, sollte wenigstens in A20 auf Tabelle2 eine 1 stehen, da A1 ja eine Schriftfarbe hat, egal, ob in der Zelle was steht oder nicht.

[Kuwer]

Hallo André,

wenn Du verschiedene Füllfarben hättest, ... ;)

Gruß Uwe