Ich möchte über bedingte Formatierung einen Farbverlauf wie in den Zellen G24 bis G27 (s. Anhang) dargestellt für die Zahlen (Werte) und nicht für die Füllung der Zellen erzeugen.
29.09.2022, 14:52 (Dieser Beitrag wurde zuletzt bearbeitet: 29.09.2022, 14:56 von HKindler.)
Hi,
Excel bietet einen Farbverlauf nur für den Hintergrund, nicht aber für die Schriftfarbe an. Da ich mir selbst mal einen Farbverlauf programmiert habe, kann ich dir eine Lösung mit VBA anbieten. Folgende Codes gehören in ein allgemeines Modul:
Code:
Option Explicit
Function RGBFarbverlauf(ByVal ZielWert As Double, _ ByVal Wert1 As Double, ByVal RGBFarbe1 As Long, _ ByVal Wert2 As Double, ByVal RGBFarbe2 As Long, _ Optional ByVal Wert3 As Double, _ Optional ByVal RGBFarbe3 As Variant) _ As Long 'gibt eine Farbe innerhalb eines Farbverlaufs zurück 'ZielWert: Wert für den die Farbe bestimmt wird 'Wert1: kleinster Wert 'RGBFarbe1: zugehörige Farbe 'Wert2: mittlerer bzw. höchster Wert 'RGBFarbe2: zugehörige Farbe 'Wert3: höchster Wert (optional für 3-Farb-Skala) 'RGBFarbe3: zugehörige Farbe (optional) ' 'Soll ein Hintergrund-Farbverlauf ähnlich der bedingten Formatierung 'erzeugt werden, so wird die Funktion wie folgt eingesetzt. 'Im Beispiel ist ein Farbverlauf von dunkelgrün bis hellgrün hinterlegt, 'der sich zwischen 0 und 10 abspielt. Die Hintergrundfarbe liegt etwas 'über der Mitte ' ' Range("A1").Interior.Color = RGBFarbverlauf(5.5, _ ' 0, RGB(0,125,0), _ ' 10, RGB(0,255,0)) ' Dim Rot1 As Integer, Grün1 As Integer, Blau1 As Integer Dim Rot2 As Integer, Grün2 As Integer, Blau2 As Integer Dim Rot3 As Integer, Grün3 As Integer, Blau3 As Integer Dim iRot As Integer, iGrün As Integer, iBlau As Integer Dim dProz As Double 'Werte der Größe nach sortieren If Not IsMissing(RGBFarbe3) Then If Wert3 < Wert2 Then WerteTauschen Wert2, Wert3 WerteTauschen RGBFarbe2, RGBFarbe3 End If End If If Wert2 < Wert1 Then WerteTauschen Wert1, Wert2 WerteTauschen RGBFarbe1, RGBFarbe2 End If If ZielWert <= Wert1 Then RGBFarbverlauf = RGBFarbe1: Exit Function If ZielWert < Wert2 Then GetRGB RGBFarbe1, Rot1, Grün1, Blau1 GetRGB RGBFarbe2, Rot2, Grün2, Blau2 dProz = Prozentual(ZielWert, Wert1, Wert2) iRot = dProz * (Rot2 - Rot1) + CDbl(Rot1) + 0.5 iGrün = dProz * (Grün2 - Grün1) + CDbl(Grün1) + 0.5 iBlau = dProz * (Blau2 - Blau1) + CDbl(Blau1) + 0.5 RGBFarbverlauf = RGB(iRot, iGrün, iBlau) Exit Function End If RGBFarbverlauf = RGBFarbe2 If Not IsMissing(RGBFarbe3) Then If ZielWert < Wert3 Then GetRGB RGBFarbe2, Rot2, Grün2, Blau2 GetRGB CLng(RGBFarbe3), Rot3, Grün3, Blau3 dProz = Prozentual(ZielWert, Wert2, Wert3) iRot = dProz * (Rot3 - Rot2) + CDbl(Rot2) + 0.5 iGrün = dProz * (Grün3 - Grün2) + CDbl(Grün2) + 0.5 iBlau = dProz * (Blau3 - Blau2) + CDbl(Blau2) + 0.5 RGBFarbverlauf = RGB(iRot, iGrün, iBlau) Exit Function End If RGBFarbverlauf = RGBFarbe3 End If End Function
Sub GetRGB(lRGB As Long, ByRef Red As Integer, _ ByRef Green As Integer, ByRef Blue As Integer) Red = lRGB And 255 Green = lRGB \ 256 And 255 Blue = lRGB \ 256 ^ 2 And 255 End Sub
Function Prozentual(ByVal Wert As Double, ByVal Min As Double, _ ByVal Max As Double) As Double If Wert <= Min Then Prozentual = 0: Exit Function If Wert >= Max Then Prozentual = 1: Exit Function Prozentual = (Wert - Min) / (Max - Min) End Function
Sub WerteTauschen(ByRef Wert1, ByRef Wert2) Dim temp As Variant temp = Wert1 Wert1 = Wert2 Wert2 = temp End Sub
Und dieser Code in das Code-Modul deines Tabellenblattes:
Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim Bereich As Range Dim Bereich2 As Range Dim Zelle As Range Dim Rot As Long, Gruen As Long, Gelb As Long Rot = RGB(255, 0, 0) Gruen = RGB(0, 139, 0) Gelb = RGB(255, 235, 132) 'Auftrittstiefe Set Bereich = Intersect(Target, Range("C7:C11,C24:C27")) '23<=A<=37 OK, 26<=A<=32 Gut If Not Bereich Is Nothing Then For Each Zelle In Bereich With Zelle Select Case .Value Case Is <= 29 .Font.Color = RGBFarbverlauf(.Value, 23, Rot, 26, Gelb, 29, Gruen) Case Else .Font.Color = RGBFarbverlauf(.vlaue, 37, Rot, 32, Gelb, 29, Gruen) End Select End With Next Zelle End If 'Steigungshöhe Set Bereich = Intersect(Target, Range("D7:D11,D24:D27")) '14<=S<=20 OK If Not Bereich Is Nothing Then For Each Zelle In Bereich With Zelle .Font.Color = RGBFarbverlauf(.Value, 14, Rot, 17, Gruen, 20, Rot) End With Next Zelle End If 'Schrittmaßregel 'Zellen haben Formel, daher mit Vorläuferzellen vergleichen Set Bereich = Intersect(Target, Range("F7:F11,F24:F27").Precedents) If Not Bereich Is Nothing Then 'Nachfolgezellen der ermittelten Zellen mit Ursprungsbereich vergleichen Set Bereich = Intersect(Bereich.Dependents, Range("F7:F11,F24:F27")) '59<=2S+A<=65 OK, 63 ideal For Each Zelle In Bereich With Zelle .Font.Color = RGBFarbverlauf(.Value, 59, Rot, 63, Gruen, 65, Rot) End With Next Zelle End If 'Bequemlichkeitsregel 'Zellen haben Formel, daher mit Vorläuferzellen vergleichen Set Bereich = Intersect(Target, Range("G7:G11,G24:G27").Precedents) If Not Bereich Is Nothing Then 'Nachfolgezellen der ermittelten Zellen mit Ursprungsbereich vergleichen Set Bereich = Intersect(Bereich.Dependents, Range("G7:G11,G24:G27")) 'A-<=12 OK, 12 ideal For Each Zelle In Bereich With Zelle If .Value > 12 Then .Font.Color = Rot Else .Font.Color = RGBFarbverlauf(.Value, 0, Rot, 6, Gelb, 12, Gruen) End If End With Next Zelle End If 'Sicherheitsregel 'Zellen haben Formel, daher mit Vorläuferzellen vergleichen Set Bereich = Intersect(Target, Range("H7:H11,H24:H27").Precedents) If Not Bereich Is Nothing Then 'Nachfolgezellen der ermittelten Zellen mit Ursprungsbereich vergleichen Set Bereich = Intersect(Bereich.Dependents, Range("H7:H11,H24:H27")) '45<=A+S<=47 OK, 46 ideal For Each Zelle In Bereich With Zelle .Font.Color = RGBFarbverlauf(.Value, 45, Rot, 46, Gruen, 47, Rot) End With Next Zelle End If 'Neigungswinkel 'Zellen haben Formel, daher mit Vorläuferzellen vergleichen Set Bereich = Intersect(Target, Range("I7:I11,I24:I27").Precedents) If Not Bereich Is Nothing Then 'Nachfolgezellen der ermittelten Zellen mit Ursprungsbereich vergleichen Set Bereich = Intersect(Bereich.Dependents, Range("I7:I11,I24:I27")) '22<=x<=40° OK, 30-32 ideal For Each Zelle In Bereich With Zelle Select Case .Value Case Is < 30 .Font.Color = RGBFarbverlauf(.Value, 22, Rot, 26, Gelb, 30, Gruen) Case Is > 32 .Font.Color = RGBFarbverlauf(.Value, 40, Rot, 36, Gelb, 32, Gruen) Case Else .Font.Color = Gruen End Select End With Next Zelle End If End Sub
Wenn du nun einen Wert in C7:D11 oder C24:D27 änderst, werden die Zahlen in diesen Zellen und den Zellen der Spalten F:I der selben Zeile geändert.
