shitzovran
Jan 13, 2011, updated at 09:17:24 (UTC)
view8115
view5
0
Goto Top

Automatisiertes Erstellen von Exceldiagrammen

GermansolvedQuestionVB for ApplicationsDevelopment

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.

9647324cbeb10ca5222ec3a62258e1fa


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

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

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 face-smile

roxxYOURsoxx
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 158541

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

Printed on: April 25, 2024 at 02:04 o'clock

5 Comments
Latest comment
Goto Top
Mitglied: 76109
76109 Jan 14, 2011 at 09:05:08 (UTC)
Goto Top
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
Member: ShitzOvran
ShitzOvran Mar 22, 2011 at 15:23:47 (UTC)
Goto Top
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
...
Mitglied: 76109
76109 Mar 23, 2011 at 09:50:25 (UTC)
Goto Top
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 werdenface-wink

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
Member: ShitzOvran
ShitzOvran Mar 25, 2011 at 12:46:58 (UTC)
Goto Top
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
Mitglied: 76109
76109 Mar 26, 2011 at 14:39:19 (UTC)
Goto Top
Hallo ShitzOvran!

Na, dann eben so face-smile
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

Gruß Dieter
GermansolvedQuestionVB for ApplicationsDevelopment
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 5 CommentsjstrickerWireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 Comments