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, 13:52 (Dieser Beitrag wurde zuletzt bearbeitet: 29.09.2022, 13: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.
