Bedingte Formatierung für Diagramme

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