AW: VBA Sunburst-Diagramm Farbe ändern.
05.06.2025 15:18:06
Hans Werner Herber
Hallo,
sorry, da muss ich mich für meine kurze Antwort entschuldigen; ich hatte die Sache zu einfach gesehen.
Als Entschuldigung beiliegend die Arbeitsmappe mit einer Lösung zurück.
Einfach nur auf die jeweiligen Schaltflächen klicken.
Die Downloadadresse:
https://www.herber.de/bbs/user/177676.xlsm
Gruß hans
Der Code:
Option Explicit
Sub FarbwechselSunburst()
Dim btn As Button
Dim cht As Chart
Dim srs As Series
Dim lColor As Long
Dim iPoint As Integer, iCall As Integer
Dim sGreen As String, sYellow As String, sRed As String, sCaller As String, sRGB As String
Set btn = ActiveSheet.Buttons(Application.Caller)
sCaller = btn.Caption
If btn.TopLeftCell.Column = 2 Then
lColor = Range("GREEN").Interior.Color
ElseIf btn.TopLeftCell.Column = 5 Then
lColor = Range("YELLOW").Interior.Color
ElseIf btn.TopLeftCell.Column = 8 Then
lColor = Range("RED").Interior.Color
End If
If sCaller Like "Class I *" Then
If sCaller Like "* innen" Then
Call SetElements(10, lColor, 1)
ElseIf sCaller Like "* mitte" Then
Call SetElements(10, lColor, 2)
ElseIf sCaller Like "* außen" Then
Call SetElements(10, lColor, 3)
End If
ElseIf sCaller Like "*Class II *" Then
MsgBox "Für ""Class II"" existieren keine Daten"
Exit Sub
' If sCaller Like "* innen" Then
' Call SetElements(10, lColor, 1)
' ElseIf sCaller Like "* mitte" Then
' Call SetElements(10, lColor, 2)
' ElseIf sCaller Like "* außen" Then
' Call SetElements(10, lColor, 3)
' End If
ElseIf sCaller Like "*Class III*" Then
If sCaller Like "* innen" Then
Call SetElements(7, lColor, 1)
ElseIf sCaller Like "* mitte" Then
Call SetElements(7, lColor, 2)
ElseIf sCaller Like "* außen" Then
Call SetElements(7, lColor, 3)
End If
ElseIf sCaller Like "*Class V*" Then
If sCaller Like "* innen" Then
Call SetElements(1, lColor, 1)
ElseIf sCaller Like "* mitte" Then
Call SetElements(1, lColor, 2)
ElseIf sCaller Like "* außen" Then
Call SetElements(1, lColor, 3)
End If
Else
If sCaller Like "* innen" Then
Call SetElements(4, lColor, 1)
ElseIf sCaller Like "* mitte" Then
Call SetElements(4, lColor, 2)
ElseIf sCaller Like "* außen" Then
Call SetElements(4, lColor, 3)
End If
End If
End Sub
Sub SetElements(iPunkt As Integer, lColor As Long, iMod As Integer)
Dim cht As Chart
Dim srs As Series
Dim iAct As Integer
Dim lColorA As Long, lColorB As Long, lColorC As Long
'Call ResetChart
Set cht = ActiveSheet.ChartObjects(1).Chart
Set srs = cht.SeriesCollection(1)
lColorA = srs.Points(iPunkt).Format.Fill.ForeColor.RGB
lColorB = srs.Points(iPunkt + 1).Format.Fill.ForeColor.RGB
lColorC = srs.Points(iPunkt + 2).Format.Fill.ForeColor.RGB
If iMod = 1 Then
srs.Points(iPunkt).Format.Fill.ForeColor.RGB = lColor
srs.Points(iPunkt + 1).Format.Fill.ForeColor.RGB = lColorB
srs.Points(iPunkt + 2).Format.Fill.ForeColor.RGB = lColorC
ElseIf iMod = 2 Then
srs.Points(iPunkt + 1).Format.Fill.ForeColor.RGB = lColor
srs.Points(iPunkt + 2).Format.Fill.ForeColor.RGB = lColorC
ElseIf iMod = 3 Then
srs.Points(iPunkt + 2).Format.Fill.ForeColor.RGB = lColor
End If
End Sub
Sub ResetChart()
Dim cht As Chart
Dim srs As Series
Dim iAct As Integer
Set cht = ActiveSheet.ChartObjects(1).Chart
For Each srs In cht.SeriesCollection
For iAct = 1 To 12
srs.Points(iAct).Format.Fill.ForeColor.RGB = RGB(0, 0, 0)
Next iAct
Next srs
End Sub