Moin,
ich würde gerne bei einem Ringdiagramm mittels VBA die Farbe eines der Ringsegmente ändern, sobald sich der Wert in einer Zelle sich ändert.
Mein Diagramm habe ich mittels Macro-Recorder erstellt bekommen. Nicht unbedingt schön, aber es funktioniert.
Mit:
ActiveChart.SeriesCollection(1).Points(2).Select
With Selection.Interior
.ColorIndex = 0 'weiß
.Pattern = xlSolid
End With
Habe ich das zweite Ringsegment quasi ausgeblendet.
Das erste Ringsegment versuchte ich so anzupassen, sodass die Farbe sich auf Rot ändert, wenn der Wert in Zelle P9 größer 89 ist.
Mein letzter Versuch war:
ActiveChart.SeriesCollection(1).Points(1).Select
If Range("P9").Value > 89 Then
ActiveChart.SeriesCollection(1).Points(1).ColorIndex = 3
End If
Mein Ziel ist es, ein farbliches Ringsegment zu haben, wenn der Wert in Zelle P9:
Größer 89 = grünes Ringsegment.
Zwischen 75-89 = oranges Ringsegment.
Und kleiner 75 = rotes Ringsegment.
Mit freundlichen Grüßen
Björn
Hallo,
hier ein Code der jedes Element farbig markiert. Es werden aber die RGB-Farben benötigt.
Im Beisiel werden die ersten 4 von 16 Feldern individuell gefärbt:
Code:
Sub Sunburst()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim Cht As ChartObject, Car As Chart, Pts As Points
Set Cht = WS.ChartObjects(1)
Set Car = Cht.Chart
Set Pts = Car.SeriesCollection(1).Points
Pts(1).Format.Fill.ForeColor.RGB = RGB(20, 80, 120)
Pts(2).Format.Fill.ForeColor.RGB = RGB(120, 180, 220)
Pts(3).Format.Fill.ForeColor.RGB = RGB(90, 200, 150)
Pts(4).Format.Fill.ForeColor.RGB = RGB(200, 80, 100)
End Sub
mfg
(26.08.2022, 16:53)Fennek schrieb: [ -> ]Hallo,
hier ein Code der jedes Element farbig markiert. Es werden aber die RGB-Farben benötigt.
Im Beisiel werden die ersten 4 von 16 Feldern individuell gefärbt:
Code:
Sub Sunburst()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim Cht As ChartObject, Car As Chart, Pts As Points
Set Cht = WS.ChartObjects(1)
Set Car = Cht.Chart
Set Pts = Car.SeriesCollection(1).Points
Pts(1).Format.Fill.ForeColor.RGB = RGB(20, 80, 120)
Pts(2).Format.Fill.ForeColor.RGB = RGB(120, 180, 220)
Pts(3).Format.Fill.ForeColor.RGB = RGB(90, 200, 150)
Pts(4).Format.Fill.ForeColor.RGB = RGB(200, 80, 100)
End Sub
mfg
Moin,
danke für das Beispiel, allerdings verstehe ich nicht, wie der Zellenbezug zum Ringsegment funktioniert.
Ich verstehe den Code so, dass Pts(1-4) die Ringsegmente sind, aber woher weiß das Ringsegment, dass z. B in der Zelle C2 sich der Wert geändert hat?
Gruß
Björn
Hallo Björn,
lade bitte eine Beispiel-Datei hoch:
Die
- Anzahl der Spalten
- Anzahl der Zeilen
- Position in Sheet
muss dem Original entsprechen, die Labels können auch "L1...Ln" sein. In der ausgangsfrage war die Zelle P9 entscheidend, dies muss im Beispiel ebenso sein.
mfg
(27.08.2022, 11:25)Fennek schrieb: [ -> ]Hallo Björn,
lade bitte eine Beispiel-Datei hoch:
Die
- Anzahl der Spalten
- Anzahl der Zeilen
- Position in Sheet
muss dem Original entsprechen, die Labels können auch "L1...Ln" sein. In der ausgangsfrage war die Zelle P9 entscheidend, dies muss im Beispiel ebenso sein.
mfg
Moin,
anbei das angefragte Beispiel, es entspricht meinem Vorhaben.
Gruß
Björn
Bonjour,
eine hoffentlich smarte VBA-Solution:
Wenn in Zeile 9 ein neuer Wert von Hand eingegeben wird oder der "Refresh" (pardon pour anglicism), ändert sich die Farbe nach den Wünschen des Ausgangspost.
In einem allgemeinen Modul:
Code:
Sub F_en()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim Cht As ChartObject, Car As Chart, Pts As Points
Set Cht = WS.ChartObjects(1)
Set Car = Cht.Chart
Set Pts = Car.SeriesCollection(1).Points
Select Case Range("P9")
Case Is > 89: Pts(1).Format.Fill.ForeColor.RGB = RGB(128, 234, 22) 'grün
Case Is > 75: Pts(1).Format.Fill.ForeColor.RGB = RGB(255, 192, 0) 'orange
Case Else: Pts(1).Format.Fill.ForeColor.RGB = RGB(255, 0, 0) 'rot
End Select
End Sub
Im Code-Modul des Sheets:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 9 Then F_en
End Sub
mfg
(27.08.2022, 12:26)Fennek schrieb: [ -> ]Bonjour,
eine hoffentlich smarte VBA-Solution:
Wenn in Zeile 9 ein neuer Wert von Hand eingegeben wird oder der "Refresh" (pardon pour anglicism), ändert sich die Farbe nach den Wünschen des Ausgangspost.
In einem allgemeinen Modul:
Code:
Sub F_en()
Dim WS As Worksheet: Set WS = ActiveSheet
Dim Cht As ChartObject, Car As Chart, Pts As Points
Set Cht = WS.ChartObjects(1)
Set Car = Cht.Chart
Set Pts = Car.SeriesCollection(1).Points
Select Case Range("P9")
Case Is > 89: Pts(1).Format.Fill.ForeColor.RGB = RGB(128, 234, 22) 'grün
Case Is > 75: Pts(1).Format.Fill.ForeColor.RGB = RGB(255, 192, 0) 'orange
Case Else: Pts(1).Format.Fill.ForeColor.RGB = RGB(255, 0, 0) 'rot
End Select
End Sub
Im Code-Modul des Sheets:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 9 Then F_en
End Sub
mfg
Moin,
vorab danke ich Dir für Deinen Lösungsvorschlag, der auch funktioniert, nur nicht integriert in meinem Makro.
Ich habe Deinen Code wie angegeben getestet und das funktioniert bei einem Blanco Sheet einwandfrei.
Wenn ich allerdings Deinen Code in mein Makro einbaue (wie, beschrieben im separaten Modul und der andere Teil in das Sheet Modul) passiert gar nichts. Nicht einmal eine Fehlermeldung!
Ich habe das mittels VBA erstellte Diagramm auch mal gelöscht und einfach nur mittels des Zellenbereichs ein Diagramm erzeugt, es funktioniert dennoch nicht.
Irgendwas in meinem Makro scheint wohl Deinen Code zu stören, ich finde aber nicht den Fehler.
Gruß
Björn
In dieser Datei sind die Codes verbunden, also beim Erstellen des Chart wird die Zelle P9 geprüft und die Farbe je nach Wert gesetzt.
Es ist ziemlich mühsam ...
(30.08.2022, 10:57)Fennek schrieb: [ -> ]In dieser Datei sind die Codes verbunden, also beim Erstellen des Chart wird die Zelle P9 geprüft und die Farbe je nach Wert gesetzt.
Es ist ziemlich mühsam ...
Moin,
erneut bedanke ich mich bei Dir für Deine Geduld und Hilfe.
Der Code funktioniert jetzt so, wie er es soll, das ist die gute Nachricht.
Der Code ist sicherlich nicht besonders schön und viel zu umständlich, aber sei's drum.
Mein Ergebnis basiert auf einer Kombination Deiner Lösungsvorschläge.
Ich lasse den Code jedes Mal neu ausführen, sobald sich ein Wert in der Zeile 9 ändert.
Ein Problem bleibt jetzt noch.
Wenn jemand das Digramm löscht, dann funktionieret der Code nicht mehr, weil der Code damit beginnt, das vorhandene Diagramm zu löschen, damit nicht unendlich viele Digramme erstellt werden.
Ja, ich weiß, das klingt komisch, aber ich habe mir das irgendwie hingebastelt, bin halt kein VBA-Crack.
Blattschutz funktioniert nicht, weil das Digramm nicht aktualisiert werden kann.
Meine Lösung wäre jetzt, ein weiteres Makro zu erstellen, welches mittels Button ein neues Digramm erstellt, damit der eigentliche Code wieder funktioniert.
Gäbe es eine elegantere Lösung?
Hallo,
spontan sehe ich 2 Möglichkeiten
- Sheet.Protect
- Prüfen, ob ein Chart existiert
Einfach zu realisieren ist:
Code-Teil des Workbooks:
Code:
Private Sub Workbook_Open()
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets(1)
WS.Protect , , , , 1
End Sub
Das "UserInterfaceOnly" erlaubt nur Änderungen per VBA.
In einem allgemeinen Modul sollte spezifiziert werden, welche Zellen ein User ändern darf:
Code:
Sub Daten_unprtect()
Range("A9:N9").Locked = False
End Sub
mfg