AW: Farbgebung Bubblechart aus zusätzlicher Serie?
13.06.2019 23:24:14
Rainer
Hallo Thomas,
färbe deine Wahrscheinlichkeiten mit bedingter Formatierung ein. Dann nimm diesen Code:
Gruß, Rainer
Sub Conditional_Format_for_Graphs_V3()
'Select a Series from a Chart, the Points will be coloured according to the Backgraund Colour
'Also works with Conditional Formating of the Cells
'New option: if no Series is selected, all Series are chosen
'New Option: Offset parameter for RaZelle
'Tested for Column Chart, Line chart with Markers, Pie and doughnut charts, Doughnut Charts, _
Bar Chart
'XY (scatter) and bubble chart, Bubble Chart
'Treemap chart (Office 2016 and newer versions only)
'Sunburst chart (Office 2016 and newer versions only)
'Waterfall charts (Office 2016 and newer versions only)
'Map chart (Excel only)
'Not working with: Area Chart, Stock Chart, Surface Chart, Radar Charts
'Histogram charts (Office 2016 and newer versions only)
'Box and Whisker charts (Office 2016 and newer versions only)
'Funnel charts (Office 2016 and newer versions only)
'Combo charts (Office 2013 and newer versions only)
Dim RaZelle As Range
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
If MsgBox("No Series selected, continue with all Series?", vbYesNo, "Warning") = vbYes _
Then
I = 1
Else
Exit Sub
End If
End If
For SeriesI = 1 To ActiveChart.SeriesCollection.Count
SeriesFormula = ActiveChart.SeriesCollection(SeriesI).Formula
X1 = InStr(SeriesFormula, ",") 'Ende Name
X1 = InStr(X1 + 1, SeriesFormula, ",") 'Ende X-Achse
X2 = InStr(X1 + 1, SeriesFormula, "!") 'Ende Blattname
X1 = InStr(X1 + 1, SeriesFormula, ",")
ValueRange = Mid(SeriesFormula, X2 + 1, X1 - X2 - 1)
If ValueRange = "" Then 'Treemap
Dim chtObj1 As ChartObject
Dim chtObj2 As ChartObject
Set chtObj1 = ActiveChart.Parent
Set chtObj2 = chtObj1.Duplicate.Chart.Parent
chtObj2.Activate
ActiveChart.ChartType = xlLine
SeriesFormula = ActiveChart.SeriesCollection(1).Formula
X1 = InStr(SeriesFormula, ",") 'Ende Name
X1 = InStr(X1 + 1, SeriesFormula, ",") 'Ende X-Achse
X2 = InStr(X1 + 1, SeriesFormula, "!") 'Ende Blattname
X1 = InStr(X1 + 1, SeriesFormula, ",")
ValueRange = Mid(SeriesFormula, X2 + 1, X1 - X2 - 1)
ActiveChart.Parent.Delete
chtObj1.Activate
ActiveChart.FullSeriesCollection(1).Select
End If
I = 1
For Each RaZelle In ActiveSheet.Range(ValueRange)
If RaZelle.DisplayFormat.Interior.Color 16777215 Then
ActiveChart.SeriesCollection(SeriesI).Points(I).Format.Fill.ForeColor.RGB = _
RaZelle.Offset(0, 3).DisplayFormat.Interior.Color
End If
I = I + 1
Next RaZelle
Next SeriesI
End Sub