Alle Tabellenblätter - Druckbereich - neue Datei...

Frage: In meiner Datei habe ich viele Tabellenblätter die alle gleich aufgebaut sind. Alle bis auf das letzte Blatt (das ist eine Zusammenfassung) haben einen Druckbereich. Da in den anderen Bereichen sensible Daten stehen möchte ich von allen Tabellenblättern nur den Druckbereich in eine neue Datei kopieren. Jeweils auch in ein eigenes Blatt - welches den gleichen Namen wie das Ursprungstabellenblatt haben soll. Es sind auch Formeln vorhanden - diese sollen im neuen Tabellenblatt nicht mehr vorhanden sein. Am Schluss soll ein Speicherdialog aufgerufen werden mit vorgeschlagenem Verzeichnis (das gleiche wie die Originaldatei) und einem Namen mit Zusatz vom aktuellen Datum plus Uhrzeit - wie geht das?

Hier noch eine Beispieldatei: Alle Tabellenblaetter - Druckbereich - neue Datei...

Option Explicit
Const strTMP As String = "backup"
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.10.2012 
' Purpose   : Alle Tabellenblaetter - Druckbereich - neue Datei... 
'-------------------------------------------------------------------------- 
Sub Main()
    Dim wkbBook As Workbook
    Dim intTMP As Integer
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Workbooks.Add -4167
    Set wkbBook = ActiveWorkbook
    With wkbBook
        .Worksheets.Add After:=.Worksheets(.Worksheets.Count), _
            Count:=ThisWorkbook.Worksheets.Count - 2
    End With
    For intTMP = 1 To ThisWorkbook.Worksheets.Count
        If ThisWorkbook.Worksheets(intTMP).PageSetup.PrintArea <> "" Then
            With ThisWorkbook.Worksheets(intTMP)
                .Range(.PageSetup.PrintArea).Copy
            End With
            wkbBook.Worksheets(intTMP).Name = _
                ThisWorkbook.Worksheets(intTMP).Name
            With wkbBook.Worksheets(intTMP).Range("A1")
                .PasteSpecial 8
                .PasteSpecial -4163
                .PasteSpecial -4122
            End With
            With wkbBook.Worksheets(intTMP).UsedRange
                .Value = .Value
            End With
            With Application
                .Goto wkbBook.Worksheets(intTMP).Range("A1"), True
                .CutCopyMode = True
            End With
        End If
    Next intTMP
    With Application
        .Goto wkbBook.Worksheets(1).Range("A1"), True
        .Dialogs(xlDialogSaveAs).Show ThisWorkbook.Path & _
            "\" & strTMP & "_" & Format(Now, "dd_mm_yyyy_hh_mm_ss")
    End With
    wkbBook.Close False
Fin:
    Set wkbBook = Nothing
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    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)...