Excel VBA mehrere Diagramme nach einander erstellen Schleife

Gregory · 2023-08-19T01:24:43+00:00

Hallo zusammen, nach dem ich schon einige male von Beiträgen und Lösungen in diesem Forum partizipiert habe, habe ich mich entschlossen hier zu registrieren um Euch Excel und VBA Profis an meinen Herausforderungen teilhaben zu lassen, in der Hoffnung dass diese Herausforderung für Euch nicht besonders groß ist. Ich habe eine Tabelle mit mehreren Tbellenblättern. Blatt 1 = Daten werden gesammelt, immer aktuellere Werte werden unten drunter eingefügt, die Beispiel Datei. ( die Datenreihen werden mittels Bereichsnamen gesteuert ) Blatt 2 = hier werden für die Daten ausgewertet und nach gewissen Kriterien eine Sortierung für die Daten berechnet. Meine Herausforderung liegt darin dass ich zu einer bestimmten Zeit diese einzelne Werte graphisch dargestellt haben muss um es genauer analysieren zu können. Für die Sortierung sind die Bereichsnamen auschlaggebend ( werden mittels Bereich verschieben Formel berechnet ) Viel glücklicher wäre ich wenn ich folgendes könnte: - wenn ich mit Hilfe von VBA 50 Diagramme erstellen könnte, nach einander mit den Werten von Bereichsnamen ( variabel, weil ich nicht weiss wieviel Werte vorhanden sind ) - diese Diagramme müsste natürlich auch noch die gleiche Skalierung haben ( +- 2% ) dadurch ergeben sich unterschiedliche min - max Werte - und als letztes müssten diese Diagramme auf ein Extra Blatt kopiert werden, so eine Art Dashboard Nach dem ich hier soviel geschrieben habe, stelle ich mir selber die Frage ob es überhaupt so möglich ist. Ich hoffe natürlich dass es ohne zu großen Aufwand geht und dass Ihr mirhelfen könnt. Vielen Dank für Eure Mühe vorab !

Hi Gregory,

wenn ich deine Mappe richtig interpretiere geht es eigentlich nur darum, den Wertebereich der Datenreihen "Datenreihen1" und "Fläche" immer wieder neu anzupassen, da sich nur bei diesen die Anzahl an Daten ändern kann - die anderen Datenreihen behalten jeweils ihren Bezug auf ein und dieselben Zellen. Alle Daten stehen in Tabelle "ROHES".
Außerdem müssen jeweils Min und Max, Hauptintervall und Achsenschnittpunkt angepasst werden - alle Daten dazu stehen in Tabelle "ROH1"

Die 50 Diagramm existieren in deiner Originalmappe bereits? Vom Prinzip her kannst du diese 50 Diagramme mit folgendem Code jeweils an die Anzahl an vorhandenen Daten anpassen:

Sub DiasAnpassen()

    Dim chrDia As ChartObject

    Dim serReihe As Series

    Dim lngLetzte As Long

    Dim intSpalte As Integer

    Dim rngRegal As Range   ' Variable für Regal-Nr in "ROHES", Suche in Zeile 1

    Dim rngRegal2 As Range  ' Variable für Regal-Nr in "ROH1", Suche in Spalte A ???

    Dim wks As Worksheet

    Dim dblMin As Double ' Minimum aus Spalte T

    Dim dblMax As Double ' Maximum aus Spalte U

    Dim dblInt As Double ' Intervall aus Spalte V

    Dim dblCross As Double ' Schnittpunkt aus Spalte X

    Set wks = Worksheets("ROHES")

    lngLetzte = wks.Cells(Rows.Count, 1).End(xlUp).Row

    For Each chrDia In ActiveSheet.ChartObjects

        Set rngRegal = wks.Rows(1).Find(chrDia.TopLeftCell.Value, lookat:=xlWhole)

        Set rngRegal2 = Worksheets("ROH1").Columns(1).Find(chrDia.TopLeftCell.Value, lookat:=xlWhole)

        intSpalte = rngRegal.Column

        dblMin = Worksheets("ROH1").Cells(rngRegal2.Row, "T")

        dblMax = Worksheets("ROH1").Cells(rngRegal2.Row, "U")

        dblInt = Worksheets("ROH1").Cells(rngRegal2.Row, "V")

        dblCross = Worksheets("ROH1").Cells(rngRegal2.Row, "X")

        With chrDia.Chart

            For Each serReihe In .SeriesCollection

                If serReihe.Name = "Datenreihen1" Or serReihe.Name = "FLÄCHE" Then

                    serReihe.Values = "=ROHES!" & Range(Cells(30, intSpalte), Cells(lngLetzte, intSpalte)).Address

                End If

            Next serReihe

            .Axes(xlValue).MinimumScale = dblMin

            .Axes(xlValue).MaximumScale = dblMax

            .Axes(xlValue).MajorUnit = dblInt

            .Axes(xlValue).CrossesAt = dblCross

        End With

    Next chrDia

End Sub

Der Code sucht jeweils in Tabelle "ROHES" in Zeile 1 den Inhalt der Zelle, auf der die linke obere Ecke des Diagramms liegt - also die Regalbezeichnung Regal_1, Regal_2 usw. und ermittelt dadurch die Spalte mit den Daten, wobei die letzte belegte Zeile in Spalte A berücksichtigt wird, um den Wertebereich festzulegen.
Außerdem sucht der Code in Tabelle "ROH1" Spalte A die Regalbezeichnung und ermittelt die Zeile, in der die Daten für Min, Max, Intervall und Schnittpunkt des betreffenden Diagramms stehen.

Beachte bitte unbedingt folgendes:
1. nicht ganz klar ist, aus welcher Spalte du den angepassten Schnittpunkt der Achse nimmst - das musst du anpassen
2. unklar ist, welche Spalte in Tabelle "ROH1" die Grundlage ist um festzustellen, um welches Regal (also welches Diagramm) es sich handelt - ich bin von Spalte A ausgegangen, musst du also anpassen
Ich habe im Code entsprechende Kommentare hinterlegt, sodass du weißt, auf welche Spalten sich der Code jeweils bezieht.

Bis später
Karin

https://excel-inn.de/

Das geht bei "richtigen" Diagrammen nur, indem man in der Zeichenfläche per VBA Shapes erstellt, welche die Flächen zwischen Horizontalachse und Datenreihe ausfüllen und entsprechend unterhalb der Horizonzalachse rot und oberhalb der Horizontalachse grün gefärbt werden. Das macht aus meiner Sicht jedoch keinen Sinn, weil das bei 50 Diagrammen 1. sehr lange dauert und 2. die Performance der Arbeitsmappe ungemein eingeschränken würde.

Hier ein Code, den du mal testen kannst (ausführen wenn "AAA" aktives Blatt ist):

' Start-Makro

Sub DiasErstellen()

    Dim lngLetzte As Long

    Dim intSpalte As Integer

    Dim lngZeile As Long

    Dim lngZiel As Long

    Dim lngZaehler As Long

    Dim chrDia As ChartObject

    ' mehr Diagramme als nur das "Vorlagen"-Diagramm sind vorhanden dann Makro

    ' zum Löschen der Diagramme aufrufen

    If ActiveSheet.ChartObjects.Count > 1 Then DiasLoeschen

    ' Spalten B:P leeren

    Columns("B:P").ClearContents

    lngZiel = 2

    lngZaehler = 2

    lngLetzte = Worksheets("ROH1").Cells(Rows.Count, 1).End(xlUp).Row

    ' Bildschirmaktualisierung ausschalten

    Application.ScreenUpdating = False

    ' "Vorlagen"-Diagramm kopieren

    ActiveSheet.ChartObjects(1).Copy

    For lngZeile = 2 To lngLetzte

        For intSpalte = 2 To 16 Step 2

            ' jeweils die Regal_Nr. eintragen

            Cells(lngZiel, intSpalte) = Worksheets("ROH1").Cells(lngZaehler, 10)

            ' Kopierts Diagramm einfügen

            ActiveSheet.Paste

            ' Positionen Oben und Links anpassen

            With ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)

                .Top = Cells(lngZiel, intSpalte).Top

                .Left = Cells(lngZiel, intSpalte).Left

            End With

            lngZaehler = lngZaehler + 1

            If lngZaehler > lngLetzte Then Exit For

        Next intSpalte

        If lngZaehler > lngLetzte Then Exit For

        lngZiel = lngZiel + 3

    Next lngZeile

    ActiveSheet.ChartObjects(2).Delete

    ' Bildschirmaktualisierung ausschalten

    Application.ScreenUpdating = True

    ' Makro zum Zuweisen der Wertebereiche aufrufen

    DiasWerteZuweisen

    Range("A1").Select

End Sub



' Makro zum Zuweisen der betreffenden Wertebereiche

Sub DiasWerteZuweisen()

    Dim chrDia As ChartObject

    Dim serReihe As Series

    Dim lngLetzte As Long

    Dim lngZeile As Long

    Dim intSpalte As Integer

    Dim wks As Worksheet

    Dim rngRegal As Range   ' Variable für Regal-Nr in "ROHES", Suche in Zeile 1

    Dim rngRegal2 As Range  ' Variable für Regal-Nr in "ROH1", Suche in Spalte J

    Dim dblMin As Double ' Minimum aus Spalte T

    Dim dblMax As Double ' Maximum aus Spalte U

    Dim dblInt As Double ' Intervall aus Spalte V

    Dim dblCross As Double ' Schnittpunkt aus Spalte X

    Set wks = Worksheets("ROHES")

    lngLetzte = wks.Cells(Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False

    ' Schleife über alle Diagramme

    For Each chrDia In ActiveSheet.ChartObjects

        ' Suche der Regal_Nr in Zeile 1 in ROHES

        Set rngRegal = wks.Rows(1).Find(chrDia.TopLeftCell.Value, lookat:=xlWhole)

        ' Suche der Regal_Nr in Spalte J in ROH1

        Set rngRegal2 = Worksheets("ROH1").Columns(10).Find(chrDia.TopLeftCell.Value, lookat:=xlWhole, LookIn:=xlValues)

        chrDia.Select

        intSpalte = rngRegal.Column

        ' Achsenwerte

        dblMin = Worksheets("ROH1").Cells(rngRegal2.Row, "T")

        dblMax = Worksheets("ROH1").Cells(rngRegal2.Row, "U")

        dblInt = Worksheets("ROH1").Cells(rngRegal2.Row, "V")

        dblCross = Worksheets("ROH1").Cells(rngRegal2.Row, "X")

        ' Hauptintervall muss > 0 sein sonst Laufzeitfehler

        If dblInt > 0 Then

            With chrDia.Chart

                ' Schleife über alle Datenreihen und Zuweisung der Zellen/Zellbereiche in Abhängigkeit vom Namen

                For Each serReihe In .SeriesCollection

                    Select Case serReihe.Name

                        Case "Datenreihen1", "FLÄCHE"

                            serReihe.Values = "=ROHES!" & Range(Cells(30, intSpalte), Cells(lngLetzte, intSpalte)).Address

                        Case "Beschriftung_min"

                            serReihe.XValues = "=ROH1!" & Cells(rngRegal2.Row, "P").Address

                            serReihe.Values = "=ROH1!" & Cells(rngRegal2.Row, "Q").Address

                        Case "Beschriftung_max"

                            serReihe.XValues = "=ROH1!" & Cells(rngRegal2.Row, "R").Address

                            serReihe.Values = "=ROH1!" & Cells(rngRegal2.Row, "S").Address

                        Case "Start"

                            serReihe.XValues = "=ROH1!" & Cells(rngRegal2.Row, "W").Address

                            serReihe.Values = "=ROH1!" & Cells(rngRegal2.Row, "X").Address

                        Case "Ende"

                            serReihe.XValues = "=ROH1!" & Cells(rngRegal2.Row, "Y").Address

                            serReihe.Values = "=ROH1!" & Cells(rngRegal2.Row, "Z").Address

                    End Select

                Next serReihe

                ' Achsenwerte einstellen

                .Axes(xlValue).MinimumScale = dblMin

                .Axes(xlValue).MaximumScale = dblMax

                .Axes(xlValue).CrossesAt = dblCross

                ' Diagramm aktualisieren

                .Refresh

            End With

        Else

            ' Diagramm löschen wenn Hauptintervall = 0 da keine Daten vorhanden

            chrDia.Delete

        End If

    Next chrDia

    Application.ScreenUpdating = True

End Sub



' Makro zum Löschen vorhandener Diagramme außer dem "Vorlagen"-Diagramm

Sub DiasLoeschen()

    Dim chrDia As ChartObject

    Dim intDia As Integer

    With Worksheets("AAA")

        ' mehr als 1 Diagramm sind vorhanden

        If .ChartObjects.Count > 1 Then

            ' alle Diagramme löschen vom zuletzt erstellten bis einschließlich zweitem Diagramm

            ' sodass das 1. Diagramm immer erhalten bleibt

            For intDia = .ChartObjects.Count To 2 Step -1

                .ChartObjects(intDia).Delete

            Next intDia

        End If

    End With

End Sub

Bis später
Karin

https://excel-inn.de/

Excel VBA mehrere Diagramme nach einander erstellen Schleife

Forumthread: Excel VBA mehrere Diagramme nach einander erstellen Schleife

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

VBA - Mehrere Diagramme über eine Schleife nacheinander erstellen

Inhaltsverzeichnis

Die Fragestellung

Erläuterung des Problems {#erläuterung-des-problems}

Lösung des Problems {#lösung-des-problems}

Anwendungsbeispiele aus der Praxis

Tipps

Verwandte Themenbereiche

Zusammenfassung

Beliebteste Forumthreads (12 Monate)

Excel VBA mehrere Diagramme nach einander erstellen Schleife

Forumthread: Excel VBA mehrere Diagramme nach einander erstellen Schleife

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Infobox / Tutorial

VBA - Mehrere Diagramme über eine Schleife nacheinander erstellen

Inhaltsverzeichnis

Die Fragestellung

Erläuterung des Problems {#erläuterung-des-problems}

Lösung des Problems {#lösung-des-problems}

Anwendungsbeispiele aus der Praxis

Tipps

Verwandte Themenbereiche

Zusammenfassung

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread