VBA Ringdiagramm, Farben je nach Zellenwert ändern

[Björn.412]

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

[Fennek]

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

[Björn.412]

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

[Fennek]

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

[Björn.412]

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

[Fennek]

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

[Björn.412]

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

[Fennek]

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 ...

[Björn.412]

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?

[Fennek]

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