Zwei Druckbereiche in eine PDF erzeugen

[ricci]

Hallo zusammen,

gibt es eine Möglichkeit jeweils einen Druckbereich aus zwei verschiedenen Tabellenblätter zusammenzuführen und daraus eine PDF Datei zu erzeugen?

Mit meinem Code komme ich leider nicht zum Ergebnis.

Code:

Code:

Sub PrintTwoRangesAsOnePDF()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, rng2 As Range
    Dim newFilePath As String
   
    Set ws1 = ThisWorkbook.Sheets("Vorlage")
    Set ws2 = ThisWorkbook.Sheets("Tickets")
    Set rng1 = ws1.Range("cellDruckbereich")
    Set rng2 = ws2.Range("A1:C" & lastRow)
   
    ' Den Speicherort der PDF-Datei festlegen
    newFilePath = ThisWorkbook.Path & "\" & "TwoRanges.pdf"
   
    ' Beide Bereiche in die gleiche PDF-Datei exportieren
    With ActiveSheet.PageSetup
        .PrintArea = rng1.Address & "," & rng2.Address
    End With
   
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=newFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
   
End Sub

Der Code führt dazu dass nur auf dem aktiven Tabellenblatt die beiden Ausschnitte (rng1 & rng2) ausgeschnitten und in eine PDF übertragen werden.

Vielen Dank im Voraus.

Gruß

Ricci

[Kuwer]

Hallo Ricci,

z.B. so:

Code:

Sub PrintTwoRangesAsOnePDF()
  Dim newFilePath As String
    
  ' Den Speicherort der PDF-Datei festlegen
  newFilePath = ThisWorkbook.Path & "\" & "TwoRanges.pdf"
  
  With Worksheets.Add
    With ThisWorkbook.Worksheets("Vorlage")
      .Range("cellDruckbereich").CopyPicture
    End With
    .Paste .Cells(1, 1)
    .Shapes(1).TopLeftCell.RowHeight = .Shapes(1).Height
    With ThisWorkbook.Worksheets("Tickets")
      .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).CopyPicture
    End With
    .Paste .Cells(3, 1)
'    .HPageBreaks.Add .Cells(3, 1)  'wenn auf neue Seite
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=newFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
End Sub

Gruß Uwe

[ricci]

Hallo Ricci,

z.B. so:

Code:

Sub PrintTwoRangesAsOnePDF()
  Dim newFilePath As String
   
  ' Den Speicherort der PDF-Datei festlegen
  newFilePath = ThisWorkbook.Path & "\" & "TwoRanges.pdf"
   
  With Worksheets.Add
    With ThisWorkbook.Worksheets("Vorlage")
      .Range("cellDruckbereich").CopyPicture
    End With
    .Paste .Cells(1, 1)
    .Shapes(1).TopLeftCell.RowHeight = .Shapes(1).Height
    With ThisWorkbook.Worksheets("Tickets")
      .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).CopyPicture
    End With
    .Paste .Cells(3, 1)
'    .HPageBreaks.Add .Cells(3, 1)  'wenn auf neue Seite
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=newFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
End Sub

Gruß Uwe

Hallo Uwe,

danke für deinen Lösungsansatz, klingt viel versprechend. Da ich dadurch unabhängig von Spaltenbreiten und Zeilenhöhen bin.

Leider führen zwei Zeilen Code zu einem Fehler:

Code:

    .Paste .Cells(1, 1)
    .Shapes(1).TopLeftCell.RowHeight = .Shapes(1).Height

Ich kann ehrlich gesagt nicht rausinterpretieren, was dem Compiler stört.

Magst du mir vielleicht diesbezüglich noch mal helfen?

[Kuwer]

Hallo Ricci,

ich hatte den Code getestet und er lief ohne Fehler durch.
Du könntest ja mal diese beiden Zeilen löschen und händisch eintippen. Manchmal kommen z.B. geschützte Leerzeichen (Alt+0160) durch das Kopieren und Einfügen rein.

Gruß Uwe

[ricci]

Hallo noch mal,

ch habe mir mal die .Shapes(1).Height anzeigen lassen und ich komme auf 875,25. Da liegt wohl der Fehler. Da die maximale Zeilenhöhe bei 409 liegt.

Hast du bezüglich dessen noch mal einen cleveren Vorschlag, um den Fehler zu umgehen?

Gruß

Ricci

[HKindler]

Hi,

wenn deine "Bilder" zu groß sind, dann darfst du halt nicht die Zeilenhöhe anpassen, sondern ermittelst die Zeile, bis zu der das Bild geht. Das nächste Bild fügst du dann in der übernächsten Zeile ein. Ungetestet also etwa so:

Code:

Sub PrintTwoRangesAsOnePDF()
  Dim newFilePath As String
  
  ' Den Speicherort der PDF-Datei festlegen
  newFilePath = ThisWorkbook.Path & "\" & "TwoRanges.pdf"
  
  With Worksheets.Add
    With ThisWorkbook.Worksheets("Vorlage")
      .Range("cellDruckbereich").CopyPicture
    End With
    .Paste .Cells(1, 1)
    With .Shapes(1).BottomRightCell
    With ThisWorkbook.Worksheets("Tickets")
      .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).CopyPicture
    End With
    .Paste .Shapes(1).BottomRightCell.Offset(2)
'    .HPageBreaks.Add .Shapes(1).BottomRightCell.Offset(2)  'wenn auf neue Seite
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=newFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
End Sub

[Kuwer]

Hallo Ricci,

Code:

Sub PrintTwoRangesAsOnePDF()
  Dim newFilePath As String
   
  ' Den Speicherort der PDF-Datei festlegen
  newFilePath = ThisWorkbook.Path & "\" & "TwoRanges.pdf"
   
  With Worksheets.Add
    With ThisWorkbook.Worksheets("Vorlage")
      .Range("cellDruckbereich").CopyPicture
    End With
    .Paste .Cells(1, 1)
    With ThisWorkbook.Worksheets("Tickets")
      .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).CopyPicture
    End With
    .Paste .Cells(.Shapes(1).BottomRightCell.Row + 2, 1)
'    .HPageBreaks.Add .Cells(.Shapes(1).BottomRightCell.Row + 2, 1)  'wenn auf neue Seite
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=newFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
End Sub

[ricci]

Danke an euch beiden für eure Hilfe.

Ich habe gestern Abend noch versucht selbst auf die Lösung zu kommen, ich muss aber zugeben, dass ich mit diesen Objekten und Eigenschaften noch nicht gearbeitet habe.

Nachdem ich den Code mit eurer Lösung ergänzt habe, funktioniert es im Prinzip schon sehr gut. Allerdings kriege ich den Druckbereich nicht sauber ausgerichtet.

Die beiden Shapes sind nicht vollständig oder nicht mittig im Druckbereich. 

Mag mir dazu noch mal einer von euch einen Ansatz oder freundlicherweise sogar die Lösung zur Verfügung stellen?

[schauan]

Hallöchen,

auf Basis von Uwe's Code im Prinzip so, damit es auf eine Seitenbreite passt. Dazu wird die entsprechende Einstellung - alle Spalten auf einer Seite darstellen - aktiviert.
Wenn Deine Druckbereiche bzw. Seiteninhalte unterschiedlich breit sind, müsste man das schmalere der beiden Shapes mittig zu dem breiteren ausrichten. Im Moment ist beides linksbündig.

Code:

Sub PrintTwoRangesAsOnePDF()
  Dim newFilePath As String
  
  ' Den Speicherort der PDF-Datei festlegen
  newFilePath = ThisWorkbook.Path & "\" & "TwoRanges.pdf"
  
  With Worksheets.Add
    With ThisWorkbook.Worksheets("Tabelle1")
      .Range("Druckbereich").CopyPicture
    End With
    .Paste .Cells(1, 1)
    With ThisWorkbook.Worksheets("Tabelle2")
      .Range("Druckbereich").CopyPicture
'      .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).CopyPicture
    End With
    .Paste .Cells(.Shapes(1).BottomRightCell.Row + 2, 1)
'    .HPageBreaks.Add .Cells(.Shapes(1).BottomRightCell.Row + 2, 1)  'wenn auf neue Seite

'Fuer die Seitenbreite
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .CenterHorizontally = True
        .CenterVertically = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
    Application.PrintCommunication = True

    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=newFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
End Sub