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
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
(07.03.2023, 11:09)Kuwer schrieb: [ -> ]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?
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
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
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
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
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?
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