Automatisiertes Erstellen von Exceldiagrammen

ein freundliches Hallo an die SpezialistenInnen hier im Forum
ich suche eine Möglichkeit Diagramme in Excel automatisiert erstellen zu lassen

Wie ihr in der angehängten Datei zu erkennen, habe ich eine Tabelle, in der die Felder "Person", "KW" und verschiedene Stati bereitgestellt werden.

Anhand dieser Tabelle, sollen Diagramme erstellt werden, die dann untereinander auf unterschiedlichen Datenblättern liegen.

Auf welchen Tabellenblatt das Diagramm erstellt werden soll, wird anhand eines Indikator festgestellt ("O" für Sheet "OST", "W" für "WEST"). die anzahl der Personen kann variieren. die Anzahl der Kalenderwochen ist immer gleich (hier exemplarisch 4 Wochen).

Habt ihr irgendeine Idee wie man das angehen kann? leider kenn ich mich mit VBA und Diagrammerstellung in Excel überhaupt nicht aus und wichtig ist natürlich auch noch, wie man es schafft, dass er verschieden viele Diagramme untereinander erstellt. Aufgeteilt in die einzelnen Personen...

hoffe ihr könnt mir helfen, bzw mal die Basics zum Diagramm erstellen über VBA nahebringen

roxxYOURsoxx

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 158541

Url: https://administrator.de/contentid/158541

Ausgedruckt am: 24.11.2024 um 03:11 Uhr

5 Kommentare

Neuester Kommentar

Hallo ShitzOvran!

Um Dich VBA etwas näher zu bringen, sind Charts als Einstieg wohl kaum zu empfehlen. Charts sind etwas eigen, sowohl in der Objekte-Zusammensetzung, als auch in der Code-Steuerung.

In Deinem Fall sollte es allerdings noch relativ einfach gehen.

Schritt 1: Erstelle eine Chart-Vorlage nach Deinen Wünschen in einer seperaten Tabelle mit dem Namen "Chart" (eventuell mit einem Dummy-Datensatz)
Schritt 2: Tabellenblatt "Chart" ausblenden (Format>Blatt>Ausblenden)
Schritt 3: Diesen Code im VB-Editor in ein Modul kopieren:

Option Explicit
Option Compare Text

Const SheetChart0 = "Chart"     'Tabelle - Chart-Vorlage  
Const SheetChart1 = "Ost"       'Tabelle - Chart1, Buchstabenkürzel Left(1)  
Const SheetChart2 = "West"      'Tabelle - Chart2, Buchstabenkürzel Left(1)  

Const SheetDaten = "Daten"      'Tabelle - ChartX-Daten  

Const DatenStart = 2            'Daten - Ab Zeile x  
Const DatenInterval = 4         'Daten - Anzahl Zeilen (KW's)  

Const ColSheet = 1              'Daten - Spalte Sheet-Kürzel ChartX  
Const ColName = 2               'Daten - Spalte Person/Name  

Sub CreateCharts()
    Dim SheetChartX As String, i As Long
    
    ThisWorkbook.Activate                               'Diese Arbeitsmappe aktivieren  
    
    Application.ScreenUpdating = False                  'Bildschirmaktualisierung Aus  
    
    Sheets(SheetChart1).ChartObjects.Delete             'Alle Charts entfernen in Sheet-Ost  
    Sheets(SheetChart2).ChartObjects.Delete             'Alle Charts entfernen in Sheet-West  

    With Sheets(SheetDaten)                             'Datenblöcke auswerten  
        For i = DatenStart To .Cells(.Rows.Count, ColName).End(xlUp).Row Step DatenInterval
            If .Cells(i, ColSheet) Like Left(SheetChart1, 1) Then
                SheetChartX = SheetChart1               'Sheet Chart-Ost  
            Else
                SheetChartX = SheetChart2               'Sheet Chart-West  
            End If
            
            Call SetNewChart(SheetChartX, .Cells(i, ColName))
        Next
    End With

    Application.ScreenUpdating = True                   'Bildschirmaktualisierung Ein  
End Sub

Private Sub SetNewChart(ByRef SheetChartX, ByRef RngName)
    Dim ChartTop As Double, i As Long
    
    With Sheets(SheetChartX).ChartObjects               'With Chart-Objecte  
        If .Count = 0 Then                              'Wenn Zähler Chart-Objecte = 0  
            ChartTop = 0                                'Dann Chart-Position = Top 0  
        Else
            With .Item(.Count).BottomRightCell          'Sonst Chart-Positionen ermitteln  
                ChartTop = .Top + .Height               'Sonst Chart-Position = Top X  
            End With
        End If
        
        Sheets(SheetChart0).ChartObjects(1).Copy:  .Parent.Paste    'Chart-Vorlage nach Ziel kopieren  
        
        With .Item(.Count).Chart                        'With New-Chart-Object  
            .Parent.Top = ChartTop:  .Parent.Left = 0   'Chart-Position X setzen  
            .ChartTitle.Characters.Text = RngName.Text  'Chart-Titel setzen  
            
             For i = 1 To 3                             'Chart-Datenreihen setzen  
                .SeriesCollection(i).Values = RngName.Offset(0, i + 1).Resize(DatenInterval, 1)
             Next
                                                        'Chart-X-Achse (KW's) setzen  
            .SeriesCollection(1).XValues = RngName.Offset(0, 1).Resize(DatenInterval, 1)
        End With
    End With
End Sub

Die Konstanten bei Bedarf entsprechend anpassen.

Vorzugsweise würde ich im Tabellenblatt "Daten" einen Button einfügen, der das Makro "CreateCharts" startet. Ansonsten über Makro/Tastenkombination oder wie auch immer.

Probiers mal aus!

Gruß Dieter

PS. Das Tabellenkürzel und der Personenname, muss nur 1 mal in der ersten Zeile eines Datensatzes stehen. In Deinem Beispiel also in Zeile 2, 6, 10 und 14

Hey Hallo nocheinmal,

das script is soweit angepasst und läuft eigentlich seit einigen Wochen erfolgreich.
Jetzt habe ich aber das Problem, dass das Skript nach zB 64 durchgängen einfach aufhört und Fehler ausspuckt

Laufzeitfehler '1004':  

Microsoft Excel kann die Daten  nicht einfügen

er bleibt dann hängen, wenn versucht wird das Diagramm als Vorlage einzufügen... Es scheint so, als gäbe es einen Überlauf oÄ

kann man da irgendwie was machen?

best regards
...

Hallo ShitzOvran!

Bei meinen Tests, ist bei mir ebenfalls der besagte Fehler aufgetreten. Eine Erklärung habe ich dafür allerdings nicht gefunden. Von daher neuer Versuch mit Plan B, wobei die Charts jetzt neu erstellt und nicht mehr kopiert werden

Anmerkungen:
Um eventuelle Seiteneffekte durch den alten VBA-Code auszuschließen, müssen die Tabellenblätter 'Ost' und 'West' gelöscht und neu erstellt werden.
Das Tabellenblatt mit der Chart-Vorlage wird natürlich nicht mehr benötigt.
Ausserdem sind neue Konstannten hinzugekommen: Breite, Höhe, Datenreihen-Text und Datenreihen-Farbe.

Hier der neue Code (getestet mit ca 650 Charts pro Ost/West):

Option Explicit
Option Compare Text

Const SheetChart1 = "Ost"       'Tabelle - Chart1, Buchstabenkürzel Left(1)  
Const SheetChart2 = "West"      'Tabelle - Chart2, Buchstabenkürzel Left(1)  

Const SheetDaten = "Daten"      'Tabelle - ChartX-Daten  

Const DatenStart = 2            'Daten - Ab Zeile x  
Const DatenInterval = 4         'Daten - Anzahl Zeilen (KW's)  

Const ColSheet = 1              'Daten - Spalte Sheet-Kürzel ChartX  
Const ColName = 2               'Daten - Spalte Person/Name  

Const ChartWidth = 450          'Chart-Breite  
Const ChartHeight = 293.25      'Chart-Höhe  

Const ColorD = 45               'Farbe Spalte D  
Const ColorE = 36               'Farbe Spalte E  
Const ColorF = 11               'Farbe Spalte F  

Const TextC = "Kalenderwochen"  'Text Spalte C  
Const TextD = "OFFEN"           'Text Spalte D  
Const TextE = "in Bearbeitung"  'Text Spalte E  
Const TextF = "Geschlossen"     'Text Spalte F  

Sub CreateCharts()
    Dim SheetChartX As String, i As Long
    
    ThisWorkbook.Activate                               'Diese Arbeitsmappe aktivieren  
    
    Application.ScreenUpdating = False                  'Bildschirmaktualisierung Aus  
    
    Sheets(SheetChart1).ChartObjects.Delete             'Alle Charts entfernen in Sheet-Ost  
    Sheets(SheetChart2).ChartObjects.Delete             'Alle Charts entfernen in Sheet-West  

    With Sheets(SheetDaten)                             'Datenblöcke auswerten  
        For i = DatenStart To .Cells(.Rows.Count, ColName).End(xlUp).Row Step DatenInterval
            If .Cells(i, ColSheet) Like Left(SheetChart1, 1) Then
                SheetChartX = SheetChart1               'Sheet Chart-Ost  
            Else
                SheetChartX = SheetChart2               'Sheet Chart-West  
            End If
            
            Call SetNewChart(SheetChartX, .Cells(i, ColName))
        Next
    End With

    Application.ScreenUpdating = True                   'Bildschirmaktualisierung Ein  
End Sub

Private Sub SetNewChart(ByRef SheetChartX, ByRef RngName)
    Dim ChartTop As Double, i As Long
    
    With Sheets(SheetChartX).ChartObjects
        If .Count = 0 Then
            ChartTop = 0
        Else
            With .Item(.Count).BottomRightCell
                ChartTop = .Top + .Height
            End With
        End If
        
        With .Add(Top:=ChartTop, Left:=0, Height:=ChartHeight, Width:=ChartWidth).Chart
            .ChartType = xlColumnStacked
            
             For i = 1 To 3
                .SeriesCollection.NewSeries
                .SeriesCollection(i).Name = Array("", TextD, TextE, TextF)(i)  
                .SeriesCollection(i).Values = RngName.Offset(0, i + 1).Resize(DatenInterval, 1)
                .SeriesCollection(i).Interior.ColorIndex = Array("", ColorD, ColorE, ColorF)(i)  
             Next
             
            .SeriesCollection(1).XValues = RngName.Offset(0, 1).Resize(DatenInterval, 1)
            
            .HasTitle = True
            .ChartTitle.Characters.Text = RngName.Text
            .Axes(xlCategory, xlPrimary).HasTitle = True
            .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = TextC
        End With
    End With
End Sub

Gruß Dieter

Hallihallo,
Das klappt ganz gut, leider ist natürlich dadurch die Elegance verloren gegangen, dass auch normale User diese Funktionalität ohne VBA-Wissen nutzen können. das erstellen eines Vorlagediagramms wäre schon schön.

in erster Linie interessiert mich allerdings, warum es zu solch einem Fehler kommt und ob man das vllt irgendwie umgehen kann, indem man zwischendruch irgendeinen Cache leeren kann oder ähnliches...

LG

Hallo ShitzOvran!

Na, dann eben so

Option Explicit
Option Compare Text

Const SheetChart0 = "Chart"     'Tabelle - Chart-Vorlage  
Const SheetChart1 = "Ost"       'Tabelle - Chart1, Buchstabenkürzel Left(1)  
Const SheetChart2 = "West"      'Tabelle - Chart2, Buchstabenkürzel Left(1)  

Const SheetDaten = "Daten"      'Tabelle - ChartX-Daten  

Const DatenStart = 2            'Daten - Ab Zeile x  
Const DatenInterval = 4         'Daten - Anzahl Zeilen (KW's)  

Const ColSheet = 1              'Daten - Spalte Sheet-Kürzel ChartX  
Const ColName = 2               'Daten - Spalte Person/Name  

Sub CreateCharts()
    Dim i As Long
    
    ThisWorkbook.Activate                               'Diese Arbeitsmappe aktivieren  
    
    With Application
        .StatusBar = "Diagramme werden erstellt..."  
        .ScreenUpdating = False                         'Bildschirmaktualisierung Aus  
    End With
    
    Sheets(SheetChart1).ChartObjects.Delete             'Alle Charts entfernen in Sheet-Ost  
    Sheets(SheetChart2).ChartObjects.Delete             'Alle Charts entfernen in Sheet-West  

    With Sheets(SheetChart0)
        .Visible = xlSheetVisible                       'Vorlage-Sheet einblenden  
        .ChartObjects(1).Activate                       'Vorlage-Chart aktivieren/selektieren  
    End With
    
    With Sheets(SheetDaten)                             'Datenblöcke auswerten  
        For i = DatenStart To .Cells(.Rows.Count, ColName).End(xlUp).Row Step DatenInterval
            If .Cells(i, ColSheet) Like Left(SheetChart1, 1) Then
                Call SetNewChart(SheetChart1, .Cells(i, ColName))
            Else
                Call SetNewChart(SheetChart2, .Cells(i, ColName))
            End If
        Next
    End With

    Sheets(SheetChart0).Visible = xlSheetHidden         'Vorlage-Sheet ausblenden  
    
    With Application
        .StatusBar = False                              'StatusBar "Bereit"  
        .CutCopyMode = False                            'Kopiermodus aufheben/Zwischenablage leeren  
        .ScreenUpdating = True                          'Bildschirmaktualisierung Ein  
    End With
End Sub

Private Sub SetNewChart(ByRef SheetChartX, ByRef RngName)
    Dim ChartTop As Double, i As Long, x
    
    With Sheets(SheetChartX).ChartObjects               'With Chart-Objecte  
        If .Count = 0 Then                              'Wenn Zähler Chart-Objecte = 0  
            ChartTop = 0                                'Dann Chart-Position = Top 0  
        Else
            With .Item(.Count).BottomRightCell          'Sonst Chart-Positionen ermitteln  
                ChartTop = .Top + .Height               'Sonst Chart-Position = Top X  
            End With
        End If
       
        Selection.Copy: .Parent.Paste                   'Chart-Vorlage nach Ziel kopieren  
       
        With .Item(.Count).Chart                        'With New-Chart-Object  
            .Parent.Top = ChartTop:  .Parent.Left = 0   'Chart-Position X setzen  
            .ChartTitle.Characters.Text = RngName.Text  'Chart-Titel setzen  
            
             For i = 1 To 3                             'Chart-Datenreihen setzen  
                .SeriesCollection(i).Values = RngName.Offset(0, i + 1).Resize(DatenInterval, 1)
             Next
            
            .SeriesCollection(1).XValues = RngName.Offset(0, 1).Resize(DatenInterval, 1)
        End With
    End With
End Sub