AW: "X" in Zelle wenn Schriftfarbe rot
04.02.2023 16:38:35
Yal
Hallo Joseph,
die grösste Schwierigkeit ist, dass rot nicht unbedingt gleich rot. Beim meinem Test ist rot 255. Ein leicht anderes rot wäre aber 13311. Wenn auch andere Farben mitmischen, wird es erst lustig.
Folgende Code ist ein User Defined Function. Es wird in ein allg. Modul abgelegt und im Blatt als Formel verwendet.
Public Function Farbe(ByVal Target As Range, Optional InfoTyp As String)
Dim i
Dim min%, max%
Dim tmp As Long
Dim Liste As Object
min = -1
max = -1
Set Target = Target.Cells(1) 'falls mehrere Zelle, nur die erste
Set Liste = craeteobject("scripting.dictionary")
For i = i To Len(Target.Text)
tmp = Target.Characters(i, 1).Font.Color
If tmp > 0 Then If min = -1 Or tmp min Then min = temp 'kleinsten non-Null. Null=Schwarz
If max = -1 Or tmp > max Then max = temp
Liste(tmp) = Liste(tmp) + 1
Next
Select Case LCase(InfoTyp)
Case "min": Farbe = min
Case "max": Farbe = max
Case "beide": Farbe = min & ";" & max
Case "gleich": Farbe = (min = max)
Case "liste", ""
tmp = ""
For Each i In Liste.Keys
tmp = tmp & "," & i & ":" & Liste(i)
Next
Farbe = Mid(tmp, 2) 'ohne führende ","
End Select
End Function
Die Aufruf lautet
=Farbe(A1;"min") 'die kleinste Farbwert. Schwarz ist 0 und wird gar nicht aufgelistet. Wenn alles schwarz kommt -1 raus.
=Farbe(A1;"max") 'die höchste Farbwert
=Farbe(A1;"gleich") 'ob alle dieselbe Farbe
oder
=Farbe(A1;"liste") 'alle Farbe + Anzahl an Zeichen in jeder Farbe
Somit kannst Du sehen, ob Zeichen in eine andere Farbe als schwarz vorliegen.
Ob die Farbe dann rot ist, war das eigentlich Grund, warum diese Frage interessant sein kann. Nach verschiedenen Ansätze komme ich ungefährt auf einen Ermittlung durch "Abstand": in wie weit ist die Farbe vom rot (RGB 255-0-0) entfernt, und wo ist die Grenze des "nicht mehr rot genug".
Function IstEsRot(ByVal Farbe As Long) As Boolean
Dim R&, G&, B&, RG#, RB# '& long, # Double
Const cGrenze = 80
'Teilung in Rot-Grün-Blau
R = Farbe And 255
G = (Farbe \ 256) And 255
B = (Farbe \ 65536) And 255
'Berechnung der Abstände
RG = Sqr((255 - R) ^ 2 + G ^ 2) 'Radius Rot-Grün
RB = Sqr((255 - R) ^ 2 + (2 * B) ^ 2) 'Radius Rot-Blau, Blauwert gedoppelt, weil Blau nicht so stark zieht wie Grün
'Rot oder nicht, je nach Grenzensetzung
IstEsRot = RG cGrenze And RB cGrenze
End Function
Man kann auch schon aus den Farben den RGB rechnen und sagen: erst wenn R > 200, ist es rot genug.
Dafür einen Test. Man kann an der "Grenze" ausprobieren:
Sub Test()
Dim i, z, Arr
Dim Farbe As Long
Const cRotGrenze = 200
Randomize
With ThisWorkbook.Worksheets.Add
z = 1
For i = 1 To 200
Arr = Array(WorksheetFunction.RandBetween(0, 255), WorksheetFunction.RandBetween(0, 255), WorksheetFunction.RandBetween(0, 255))
Farbe = RGB(Arr(0), Ar(1), Arr(2))
If SplitRGB(Farbe)(0) > cRotGrenze Then
z = z + 1
.Cells(z, 1).Interior.Color = Farbe
.Cells(z, 2).Resize(1, 3) = Arr
End If
Next
End With
End Sub
Endlich mal was ausserhalb von "Daten von A nach B kopieren". Hat spass gemacht.
VG
Yal