Thema: Diagramme sammeln und drucken

Hallo!

Ich werde langsam verrückt hier, da ich den Fehler einfach nicht nachvollziehen kann.

Zur Situation: Ich möchte ein Makro schreiben, das alle Diagramme auf einem Tabellenblatt sucht, und diese dann jeweils zu viert auf ein Blatt ausdruckt. Auf folgende Probleme bin ich gestoßen:

Zuerst habe ich versucht, für jedes einzelne Diagramm ein einzelnes neues Tabellenblatt zu erstellen und diese dann zu markieren und zu drucken. Leider hat das nicht funktioniert, da mir Excel dennoch immer für jedes Blatt eine einzelne Datei erstellt hat, wenn ich es als pdf speichern wollte - es muss sowohl als pdf speicherbar als auch direkt druckbar sein.

Deswegen bin ich dazu übergegangen, jeweils 4 Diagramme auf ein neues Tabellenblatt zu kopieren und dann erst zu drucken. Das funktioniert prinzipiell, allerdings werden nicht alle Diagramme kopiert und es kommt bei "newSheet.Paste" manchmal zu Fehlern? Aber eben nicht immer... Manchmal werden alle Diagramme kopiert, manchmal nicht. Manchmal hilft es, wenn ich das Makro per F8 dann einzeln weiter laufen lasse, manchmal nicht.

Hier der Code:

Sub DiagrammeDrucken()

    Dim ws As Worksheet

    Dim ch As ChartObject

    Dim newSheet As Worksheet

    Dim chartCount As Integer

    Dim tempSheets As Collection

    Dim tempSheet As Worksheet

    Dim i As Integer

    Dim rowIndex As Integer

    Dim colIndex As Integer

    Dim chartCounter As Integer

    

    Set ws = ActiveSheet

    

    chartCount = ws.ChartObjects.Count

    

    If chartCount = 0 Then

        MsgBox "Keine Diagramme auf diesem Blatt gefunden."

        Exit Sub

    End If

    

    Set tempSheets = New Collection

    chartCounter = 1

    

    Do While chartCounter <= chartCount

        

        Set newSheet = ThisWorkbook.Sheets.Add

        newSheet.Name = "Temp_" & chartCounter

        

        rowIndex = 1

        colIndex = 1

        



        For i = chartCounter To chartCounter + 3

            If i > chartCount Then Exit For

            

            ws.ChartObjects(i).CopyPicture xlScreen, xlPicture

            newSheet.Paste

            

            newSheet.Shapes(newSheet.Shapes.Count).Left = (colIndex - 1) * 300

            newSheet.Shapes(newSheet.Shapes.Count).Top = (rowIndex - 1) * 200

            

            If colIndex = 2 Then

                colIndex = 1

                rowIndex = rowIndex + 1

            Else

                colIndex = colIndex + 1

            End If

        Next i

        

        tempSheets.Add newSheet

        chartCounter = chartCounter + 4

        

    Loop

    



    Dim tempSheetNames As String

    For Each tempSheet In tempSheets

        tempSheetNames = tempSheetNames & tempSheet.Name & ","

    Next tempSheet

    tempSheetNames = Left(tempSheetNames, Len(tempSheetNames) - 1)

    

    ThisWorkbook.Sheets(tempSheetNames).Select

    



    Application.Dialogs(xlDialogPrint).Show

    



    For Each tempSheet In tempSheets

        Application.DisplayAlerts = False

        tempSheet.Delete

        Application.DisplayAlerts = True

    Next tempSheet

    

    MsgBox "Fertig! Alle Diagramme wurden gedruckt und die temporären Blätter gelöscht."

End Sub

Vielen Dank schonmal für eure Zeit und Hilfe!

VG Alex

Hi
Ohne die Datei schwer zu sagen, warum es manchmal geht und manchmal nicht.

Ist das ganze nicht unnötig kompliziert?
Du könntest auch einfach das Blatt duplizieren, die Diagramme dort an die passende Position verschieben und dann diesen Bereich drucken.
Wenn es automatisch nicht passt, kannst du ja nach jeder zweiten Diagrammreihe einen Zeilenumbruch einfügen.

Gruß Daniel

Hi, Daniel,

danke für deine Antwort!

Ich habe es versucht dementsprechend abzuändern. Das funktioniert prinzipiell auch ganz okay, aber Excel setzt immer selbst wieder unnötige Umbrüche, sodass meine Diagramme zerschnitten werden.

Sub Diagramme_Positionieren()



    Dim ws As Worksheet

    Dim diagramm As ChartObject

    Dim startX, startY, abstand, maxBreite As Single

    Dim i, j As Integer

    Dim maxReihe, maxDiagrammeProSeite, zeilenProDiagramm As Integer

    Dim form As Shape

    Dim AnzahlDiagramme As Integer

    Dim VielfachesVon6 As Integer

    Dim UmbruchZeile As Integer

        

    

    Set ws = ActiveSheet

    

    ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

    ActiveSheet.Columns.Hidden = False

    ActiveSheet.Cells.ClearContents

    

    On Error Resume Next

    

    ActiveSheet.PageSetup.PrintArea = ""

    ActiveSheet.HPageBreaks.Delete

    ActiveSheet.VPageBreaks.Delete

    

    For Each form In ActiveSheet.Shapes

        If Not form.Type = msoChart Then

            form.Delete

        End If

    Next form

    

    startX = 0

    startY = 0

    abstand = 0

    maxBreite = 300

    

    maxReihe = 2

    maxDiagrammeProSeite = 6

    zeilenProDiagramm = 15

    

    AnzahlDiagramme = ActiveSheet.ChartObjects.Count

    Debug.Print AnzahlDiagramme

    VielfachesVon6 = AnzahlDiagramme / 6

        

    i = 0

    

    For j = 1 To VielfachesVon6

        UmbruchZeile = zeilenProDiagramm * 3 * j

        Debug.Print "Umbruch: " & UmbruchZeile

        ActiveSheet.HPageBreaks.Add Before:=ActiveSheet.Rows(UmbruchZeile + 1)

    Next j



    ActiveSheet.VPageBreaks.Add Before:=ActiveSheet.Range("K1")

    

            

    For Each diagramm In ActiveSheet.ChartObjects

    

        diagramm.Height = ActiveSheet.Rows(1).RowHeight * zeilenProDiagramm

    

        If i Mod 2 = 0 Then

            diagramm.Left = startX

            diagramm.Top = startY + (i / 2) * (diagramm.Height + abstand)

        Else

            diagramm.Left = startX + maxBreite + abstand

            diagramm.Top = startY + ((i - 1) / 2) * (diagramm.Height + abstand)

        End If

        

        i = i + 1

    

    Next diagramm





    With ActiveSheet.PageSetup

        .Zoom = False

        .FitToPagesTall = False

        .FitToPagesWide = True

        .Orientation = xlPortrait

    End With

    

Application.Dialogs(xlDialogPrint).Show



End Sub

Es werden fehlerhafte Umbrüche vor den Zeilen 18, 50, 76 und 83 gesetzt. Es liegt an .FitToPagesTall=False. Allerdings bekomme ich es auch nicht ohne das zum Laufen, da er dann plötzlich gar keine Umbrüche mehr setzt, auch nicht meine.

Das Bereitstellen einer Bsp.tabelle ist etwas schwierig in diesem Fall. Vielleicht fällt es auch doch noch so auf, wo mein Fehler liegt.

Jedenfalls danke für die Zeit!

VG Alex

Ohne Datei schwer zu sagen
Wenn du die Bilder sowieso in der Höhe anpasst, solltest du das Idealerweise so einstellen, dass das Drucken mit den. Standardeinstellungen funktioniert (zoom = 100, keine Größenappassung)

Sind denn alle Zeilen gleich hoch?
Das solltest du sicherstellen.

Du könntest auch Zeilenhöhe und -breite so einstellen, dass genau zwei Zeilen und zwei Spalten auf ein Blatt passen. Dann schiebst du die Diagramme immer nur in die die jeweilige Zelle und passt Diagrammhöhe oder -Breite an die Zelle an.

Gruß Daniel