23.01.2013

Chartsheets mit Bedingung kopieren, die 2te...

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 DIAGRAMM. 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 A CHART. If the code is executed again, the newly created spreadsheet including the contained diagrams will be deleted. How does it work?

Mit einer kleinen Codeänderung funktioniert das / With a small code change works:

Hier noch eine Beispieldatei / Here's a sample file:
Chartsheets mit Bedingung kopieren, die 2te...[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_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 23.01.2013 
' Purpose   : Chartsheets kopieren, wenn String in Sheetname vorhanden... 
'-------------------------------------------------------------------------- 
Sub Chart_Copy_2()
    ' 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 Diagramm 
                objSheet.ChartArea.Copy
                ' Und füge es im neu erstellten Tabellenblatt ein 
                With Worksheets(strTerm)
                    .Paste
                    ' 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

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 ...