Diagramme per VBA Formatieren

Question

Moin,
Ich würde gern die Diagramme "Result" automatisch entsprechend der vorgegebenen Farbe einfärben. Die Diagramme sollen dabei aber vollständig auf den arrays basieren und sich vollkommen dynamisch anpassen.
--> Wenn ich also beispielsweise "Spain" hinzufüge soll in allen
Diagrammen auch Spain in der Farbe Grün hinzugefügt werden
Der Chart type variiert im weiteren und ist somit nicht auf ein Barchart und linechart begrenzt.
Ob bestehende Diagramme nur eingefärbt werden oder komplett neu erstellt werden ist jedoch egal.

A,C,D,I 2 enthalten Dynamische Arrays welche sich nur Zeilenweise Erweitern. J2 enthält ein Array welches sich auch über die Spalten J:N erstreckt.

Folgenden Code habe ich bereits mithilfe von ChatGPT erstellen können. Dieser ist jedoch nur auf nicht dynamische Bereiche begrenzt.

Sub FormatDiagramAsCellValue_help()

    Dim targetNameRange As Range

    Dim targetColorCodeRange As Range

    Dim selectedChart As chartObject

    Dim series As series

    Dim cellName As Range

    Dim cellColor As Range

    Dim targetName As String

    Dim targetColorCode As String

    Dim chartName As String

    ' Deaktiviere Aktualisierungen, um die Ausführung zu beschleunigen

    Application.ScreenUpdating = False

    ' Frage den Bereich für Namen ab

    On Error Resume Next

    Set targetNameRange = Application.InputBox("Bereich für Namen auswählen", Type:=8)

    On Error GoTo 0

    ' Überprüfe, ob der Benutzer die Eingabe abgebrochen hat oder ein ungültiger Bereich ausgewählt wurde

    If targetNameRange Is Nothing Then

        MsgBox "Abgebrochen oder ungültiger Bereich für Namen ausgewählt.", vbExclamation

        GoTo CleanupAndExit

    End If

    ' Frage den Bereich für Farbcodes ab

    On Error Resume Next

    Set targetColorCodeRange = Application.InputBox("Bereich für Farbcodes auswählen", Type:=8)

    On Error GoTo 0

    ' Überprüfe, ob der Benutzer die Eingabe abgebrochen hat oder ein ungültiger Bereich ausgewählt wurde

    If targetColorCodeRange Is Nothing Then

        MsgBox "Abgebrochen oder ungültiger Bereich für Farbcodes ausgewählt.", vbExclamation

        GoTo CleanupAndExit

    End If

    ' Frage den Benutzer nach dem Diagrammnamen

    chartName = InputBox("Geben Sie den Namen des Diagramms ein:")

    ' Überprüfe, ob ein Diagramm mit dem angegebenen Namen vorhanden ist

    On Error Resume Next

    Set selectedChart = ActiveSheet.ChartObjects(chartName)

    On Error GoTo 0

    If selectedChart Is Nothing Then

        MsgBox "Diagramm mit dem angegebenen Namen nicht gefunden.", vbExclamation

        GoTo CleanupAndExit

    End If

    ' Iteriere durch alle Zellen im Bereich für Namen

    For Each cellName In targetNameRange

        ' Überprüfe, ob die Zelle nicht leer ist

        If Not IsEmpty(cellName.Value) Then

            ' Holen des Zielnamens und Ziel-Farbcode

            targetName = cellName.Value

            ' Suche nach dem Ziel-Farbcode in der entsprechenden Zeile im Bereich für Farbcodes

            On Error Resume Next

            Set cellColor = targetColorCodeRange.Cells(cellName.Row - targetColorCodeRange.Rows(1).Row + 1, 1)

            On Error GoTo 0

            ' Überprüfe, ob der Ziel-Farbcode gefunden wurde

            If Not cellColor Is Nothing Then

                ' Holen des Ziel-Farbcodes

                targetColorCode = cellColor.Value

                ' Iteriere durch alle Datenreihen im ausgewählten Diagramm

                For Each series In selectedChart.chart.SeriesCollection

                    ' Überprüfe, ob der Name der Datenreihe mit dem Zielnamen übereinstimmt

                    If InStr(1, series.Name, targetName, vbTextCompare) > 0 Then

                        ' Setze die Farbe und den Rahmen der Datenreihe entsprechend dem Farbcode

                        series.Format.Fill.ForeColor.RGB = RGBFromHex(targetColorCode)

                        series.Format.Line.ForeColor.RGB = RGB(0, 0, 0) ' Schwarz

                        series.Format.Line.Weight = 1 ' Breite des Rahmens

                    End If

                Next series

            End If

        End If

    Next cellName

CleanupAndExit:

    ' Aktiviere Aktualisierungen

    Application.ScreenUpdating = True

End Sub

Function RGBFromHex(hexCode As String) As Long

    ' Konvertiere einen Hex-Code in eine RGB-Farbe

    Dim red As Integer, green As Integer, blue As Integer

    red = CLng("&H" & Mid(hexCode, 2, 2))

    green = CLng("&H" & Mid(hexCode, 4, 2))

    blue = CLng("&H" & Mid(hexCode, 6, 2))

    RGBFromHex = RGB(red, green, blue)

End Function

Ich hoffe hier nun endlich eine Antwort zu finden und bedanke mich bereits vor ab für jegliche Hilfe :)

Answer 1

Guten Morgen,

Bitte wende Dich an die Kollegen vom VBA Support:

Office VBA-Support und Feedback | Microsoft Learn

Ich freue mich auf Deine Rückmeldung

Mit freundlichem Gruß

Wolf Fabian Spohr

Microsoft Office 365 Business Support Engineer