Druckbereich als PDF - Alle und Einzeln...

Frage: In meiner Datei habe ich mehrere Tabellen mit Druckbereichen. Diese möchte ich alle in einer Datei haben. Erschwerend kommt hinzu, dass das Format (inklusive Zeilenhöhe) mit übernommen werden soll. Dann möchte ich die Druckbereiche noch jeweils in einer extra Datei. Wie geht das?

Hier noch eine Beispieldatei: Druckbereich als PDF - Alle und Einzeln... Dies ist eine "XLSB-Datei" - also mit rechter Maustaste anklicken und dann "Ziel speichern unter..." wählen.

Weitere Stolperfallen:
Auch noch zu beachten...

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 06.11.2012 
' Purpose   : Druckbereich als PDF... 
'-------------------------------------------------------------------------- 
Sub Main()
Dim wkbBook As Workbook
    Dim varSheet As Variant
    Dim intTMP As Integer
    Dim blnTMP As Boolean
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    varSheet = Array("Werte1", "Werte2", "Werte3", "Werte4", "Werte5")
    Workbooks.Add -4167
    Set wkbBook = ActiveWorkbook
    With wkbBook
        .Worksheets.Add After:=.Worksheets(.Worksheets.Count), _
            Count:=UBound(varSheet)
    End With
    For intTMP = Lbound(varSheet) To Ubound(varSheet)
        With ThisWorkbook.Worksheets(varSheet(intTMP))
            If .PageSetup.Orientation = 2 Then blnTMP = True
            If .PageSetup.PrintArea <> "" Then
                .Range(.PageSetup.PrintArea).Copy
            End If
        End With
        With wkbBook.Worksheets(intTMP + 1)
            .Range("A1").PasteSpecial 8
            .Range("A1").PasteSpecial -4163
            .Range("A1").PasteSpecial -4122
            If blnTMP = True Then
                .PageSetup.Orientation = 2
                blnTMP = False
            End If
            Application.Goto .Range("A1")
        End With
        With Application
            .Goto wkbBook.Worksheets(1).Range("A1"), True
            .CutCopyMode = True
        End With
    Next intTMP
    Application.Goto wkbBook.Worksheets(1).Range("A1"), True
    wkbBook.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & _
        ThisWorkbook.Name, , , , , , True
    wkbBook.Close False
Fin:
    Set wkbBook = Nothing
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul2 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 06.11.2012 
' Purpose   : Druckbereich als PDF - mit Zeilenhöhe... 
'-------------------------------------------------------------------------- 
Sub Main_1()
Dim wkbBook As Workbook
    Dim varSheet As Variant
    Dim rngRange As Range
    Dim intTMP As Integer
    Dim blnTMP As Boolean
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    varSheet = Array("Werte1", "Werte2", "Werte3", "Werte4", "Werte5")
    Workbooks.Add -4167
    Set wkbBook = ActiveWorkbook
    With wkbBook
        .Worksheets.Add After:=.Worksheets(.Worksheets.Count), _
            Count:=UBound(varSheet)
    End With
    For intTMP = Lbound(varSheet) To Ubound(varSheet)
        With ThisWorkbook.Worksheets(varSheet(intTMP))
            If .PageSetup.Orientation = 2 Then blnTMP = True
            If .PageSetup.PrintArea <> "" Then
                Set rngRange = .Range(.PageSetup.PrintArea)
                .Rows("1:" & rngRange.Rows.Count).Copy _
                    wkbBook.Worksheets(intTMP + 1).Cells
                 wkbBook.Worksheets(intTMP + 1).UsedRange.ClearContents
                .Range(.PageSetup.PrintArea).SpecialCells(12).Copy
            End If
        End With
        With wkbBook.Worksheets(intTMP + 1)
            .Range("A1").PasteSpecial 8
            .Range("A1").PasteSpecial -4163
            .Range("A1").PasteSpecial -4122
            If blnTMP = True Then
                .PageSetup.Orientation = 2
                blnTMP = False
            End If
            Application.Goto .Range("A1")
        End With
        With Application
            .Goto wkbBook.Worksheets(1).Range("A1"), True
            .CutCopyMode = True
        End With
    Next intTMP
    Application.Goto wkbBook.Worksheets(1).Range("A1"), True
    wkbBook.ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & _
        ThisWorkbook.Name, , , , , , True
    wkbBook.Close False
Fin:
    Set rngRange = Nothing
    Set wkbBook = Nothing
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul3 
' Procedure : Main_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 06.11.2012 
' Purpose   : Druckbereich als PDF - jeder Druckbereich extra Datei... 
'-------------------------------------------------------------------------- 
Sub Main_2()
    Dim varSheet As Variant
    Dim intTMP As Integer
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    varSheet = Array("Werte1", "Werte2", "Werte3", "Werte4", "Werte5")
    For intTMP = Lbound(varSheet) To Ubound(varSheet)
        With ThisWorkbook.Worksheets(varSheet(intTMP))
            .Range(.PageSetup.PrintArea).ExportAsFixedFormat 0, _
                ThisWorkbook.Path & "\" & .Name
        End With
    Next intTMP
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .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)...