Charts - Diagramme mit Bedingung kopieren...

Frage: Es gibt eine Reihe von Tabellenblättern mit eingefügten Diagrammen. Wenn eines dieser Tabellenblä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 is a series of spreadsheets with inserted diagrams. If any of these worksheets has a certain string in the name, the appropriate Chart 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:
Charts - Diagramme 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 Tabellenblattnamen vorkommen 
' damit das enthaltene Diagramm kopiert wird 
Const strTerm As String = "Test"
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Chart_Copy 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 18.01.2013 
' Purpose   : Diagramm kopieren, wenn String in Sheetname vorhanden... 
'-------------------------------------------------------------------------- 
Sub Chart_Copy()
    ' Deklarieren der Variablen 
    Dim intChartHeight As Integer
    Dim shpShapeTarget As Shape
    Dim wksSheet As Worksheet
    Dim shpShape As Shape
    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 wksSheet In ThisWorkbook.Worksheets
        ' Wenn der Tabellenblattname den Begriff irgendwo enthält, dann... 
        If InStr(1, wksSheet.Name, strTerm, vbTextCompare) > 0 Then
            ' Schleife über alle Shapes im jeweiligen Tabellenblatt 
            For Each shpShape In wksSheet.Shapes
                ' Ist das Shape ein Diagramm, dann... 
                If shpShape.Type = msoChart Then
                    ' Kopiere es als Bild 
                    shpShape.CopyPicture 1, -4147
                    ' 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 _
                            + shpShape.Height + intAbove
                    End With
                End If
                ' Objektvariable zurücksetzen 
                Set shpShapeTarget = Nothing
            Next shpShape
        End If
    Next wksSheet
    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)...