ich stelle euch hier "meine" Lösung für bedingte Formatierung von Diagrammen zur Verfügung.
Diese Variante benutzt den Colour Picker, da ich es nicht geschafft habe den Hintergundfarbwert auszulesen, wenn Zellen eine bedingte Formatierung enthalten.
Ich hoffe doch das es dem einen oder anderen hilft.
Sub Conditional_Format_for_Graphs()
'Select Series first!
On Error Resume Next
Test = ActiveChart.Name
If IsEmpty(ActiveChart.Name) Then
MsgBox "Select Graph first", vbCritical
Exit Sub
End If
If TypeName(Selection) = "Series" Then
Set ch = ActiveChart.SeriesCollection
For SeriesI = 1 To ch.Count
If ch(SeriesI).Name = Selection.Name Then I = SeriesI
Next SeriesI
Else
MsgBox "Select Series first", vbCritical
Exit Sub
End If
SeriesI = I
LL = 1 * InputBox("Set Lower Limit and pick Colour, " & vbNewLine _
& "blank or invalid value will exit function", "Conditional Formating")
If LL "" Then
LLC = PickNewColor
LLC = Color2RGB(LLC, 0, 0, 0)
Else
Exit Sub
End If
ML = 1 * InputBox("Set Middle Value and pick Colour " & vbNewLine _
& "or leave blank to use MIN/MAX only", "Conditional Formating")
If ML "" Then
MLC = PickNewColor
MLC = Color2RGB(MLC, 0, 0, 0)
Else
MLC = Array(-1, 0, 0)
End If
UL = 1 * InputBox("Set Upper Limit and pick Colour, " & vbNewLine _
& "blank or invalid value will exit function", "Conditional Formating")
If UL "" Then
ULC = PickNewColor
ULC = Color2RGB(ULC, 0, 0, 0)
Else
Exit Sub
End If
If MLC(0) = -1 Then
MLC(0) = WorksheetFunction.Average(LLC(0), ULC(0))
MLC(1) = WorksheetFunction.Average(LLC(1), ULC(1))
MLC(2) = WorksheetFunction.Average(LLC(2), ULC(2))
End If
With ActiveChart.SeriesCollection(SeriesI)
Daten = .Values
For I = 1 To UBound(Daten)
Wert = Daten(I)
If Wert = UL Then
.Points(I).Format.Fill.ForeColor.RGB = RGB(ULC(0), ULC(1), ULC(2))
ElseIf Wert = ML Then
.Points(I).Format.Fill.ForeColor.RGB = RGB(MLC(0), MLC(1), MLC(2))
ElseIf Wert > ML Then
Faktor = (Wert - ML) / (UL - ML)
R = MLC(0) + (ULC(0) - MLC(0)) * Faktor
G = MLC(1) + (ULC(1) - MLC(1)) * Faktor
B = MLC(2) + (ULC(2) - MLC(2)) * Faktor
.Points(I).Format.Fill.ForeColor.RGB = RGB(Int(R), Int(G), Int(B))
ElseIf Wert http://vba-corner.livejournal.com/1691.html
Const BGColor As Long = 13160660 'background color of dialogue
Const ColorIndexLast As Long = 32 'index of last custom color in palette
Dim myOrgColor As Double 'original color of color index 32
Dim myNewColor As Double 'color that was picked in the dialogue
Dim myRGB_R As Integer 'RGB values of the color that will be
Dim myRGB_G As Integer 'displayed in the dialogue as
Dim myRGB_B As Integer '"Current" color
'save original palette color, because we don't really want to change it
myOrgColor = ActiveWorkbook.Colors(ColorIndexLast)
If i_OldColor = xlNone Then
'get RGB values of background color, so the "Current" color looks empty
Color2RGB BGColor, myRGB_R, myRGB_G, myRGB_B
Else
'get RGB values of i_OldColor
Color2RGB i_OldColor, myRGB_R, myRGB_G, myRGB_B
End If
'call the color picker dialogue
If Application.Dialogs(xlDialogEditColor).Show(ColorIndexLast) = True Then ' _
_
Use for custom mode: Show(ColorIndexLast, myRGB_R, myRGB_G, myRGB_B)
'"OK" was pressed, so Excel automatically changed the palette
'read the new color from the palette
PickNewColor = ActiveWorkbook.Colors(ColorIndexLast)
'reset palette color to its original value
ActiveWorkbook.Colors(ColorIndexLast) = myOrgColor
Else
'"Cancel" was pressed, palette wasn't changed
'return old color (or xlNone if no color was passed to the function)
PickNewColor = i_OldColor
End If
End Function
'Converts a color to RGB values
Function Color2RGB(ByVal i_Color As Long, _
o_R As Integer, o_G As Integer, o_B As Integer)
o_R = i_Color Mod 256
i_Color = i_Color \ 256
o_G = i_Color Mod 256
i_Color = i_Color \ 256
o_B = i_Color Mod 256
Color2RGB = Array(o_R, o_G, o_B)
End Function