Chartsheets mit Bedingung kopieren...

Frage: Es gibt eine Reihe von Diagrammblätter (ChartSheets). Wenn eines dieser Diagrammblätter einen bestimmten String im Namen hat, wird das jeweilige Diagramm in ein neu erstelltes Tabellenblatt kopiert - aber als Bild. Wird der Code erneut ausgeführt, wird das neu erstellte Tabellenblatt samt den darin enthaltenen Diagrammen gelöscht. Wie geht das?

There are a number of chart sheets (chart sheets). If any of these chart sheets has a certain string in the name, the appropriate chart sheet is copied to a newly created spreadsheet - but as an image. If the code is executed again, the newly created spreadsheet including the contained diagrams will be deleted. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Chartsheets mit Bedingung kopieren...[XLS 90 KB]

Option Explicit
' Der Abstand von Oben und zwischen den Diagrammen 
Const intAbove As Integer = 20
' Der Abstand vom linken Rand 
Const intLeft As Integer = 50
' Dieser Begriff MUSS IRGENDWO im ChartSheet - Namen vorkommen 
' damit das enthaltene Diagramm kopiert wird 
Const strTerm As String = "Test"
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Chart_Copy_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 18.01.2013 
' Purpose   : Chartsheets kopieren, wenn String in Sheetname vorhanden... 
'-------------------------------------------------------------------------- 
Sub Chart_Copy_1()
    ' Deklarieren der Variablen 
    Dim intChartHeight As Integer
    Dim shpShapeTarget As Shape
    Dim objSheet As Object
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    ' Bequemlichkeit beim löschen eines 
    ' eventuell nicht vorhandenen Tabellenblattes 
    On Error Resume Next
    Worksheets(strTerm).Delete
    ' Deaktiviert die Fehlerbehandlung in der aktuellen Prozedur 
    On Error GoTo 0
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Tabellenblatt hinzufügen und gleich einen Namen vergeben 
    Worksheets.Add.Name = strTerm
    ' Schleife für jedes Tabellenblatt in dieser Datei 
    For Each objSheet In ThisWorkbook.Sheets
        ' Wenn es ein ChartSheet ist, dann... 
        If TypeOf objSheet Is Chart Then
            ' Wenn der Tabellenblattname den Begriff 
            ' irgendwo enthält, dann... 
            If InStr(1, objSheet.Name, strTerm, vbTextCompare) > 0 Then
                ' Kopiere es als Bild 
                objSheet.CopyPicture
                ' Und füge es im neu erstellten Tabellenblatt ein 
                With Worksheets(strTerm)
                    .Range("A1").PasteSpecial
                    ' Das eingefügte Bild einer Objektvariablen zuweisen 
                    Set shpShapeTarget = .Shapes(.Shapes.Count)
                    With shpShapeTarget
                        ' Den Abstand von Oben setzen 
                        .Top = intAbove + intChartHeight
                        ' Den Abstand von Links setzen 
                        .Left = intLeft
                    End With
                    ' Hochrechnen 
                    intChartHeight = intChartHeight _
                        + shpShapeTarget.Height + intAbove
                End With
                ' Objektvariable zurücksetzen 
                Set shpShapeTarget = Nothing
            End If
        End If
    Next objSheet
    Application.Goto ThisWorkbook.Worksheets(strTerm).Range("A1"), True
Fin:
    ' Objektvariable zurücksetzen 
    Set shpShapeTarget = Nothing
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...