18.01.2013

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

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...