Diagramme sammeln und drucken

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