Automatisch PDF Datei erstellen
16.04.2020 16:56:18
Schlandro
in meiner VBA Anwendung soll in einer Datei nach festgelegten Begriffen (PP,Pul,PL) gefiltert werden, der gefilterte Bereich soll dann in eine neue Datei exportiert werden und dann auf einer Seite als PDF gespeichert werden. Danach sollen die neu erstellten Dateien geschlossen werden.
Momentan werden die Dateien zwar unter dem richtigen Namen abgespeichert aber immer mit dem gefilterten Bereich für den Begriff für PP. Für Pul und PL wird also ebenfalls der Bereich von PP angezeigt. Ich komme nicht dahinter warum er immer nur diesen Bereich übernimmt und kopiert und nicht jedes mal den neuen. Vermutlich muss zunächst die Datei geschlossen werden die abgespeichert wird. Dies funktioniert bei mir aber nicht.
Hier ist mein Code:
Option Explicit
Public Sub Filtern()
Const FOLDER_PATH As String = "C:\Users\Schlandro\Desktop"
Dim objWorkbook As Workbook
Call Rows(1).AutoFilter(Field:=1, Criteria1:="PL")
Range("A1:AS600").Select
Selection.Copy
Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)
With objWorkbook.Worksheets(1)
Call .Paste(Destination:=.Cells(1, 1))
End With
Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)
With objWorkbook.Worksheets(1)
Call .Paste(Destination:=.Cells(1, 1))
Rows("4:4").RowHeight = 32.25
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
End With
With ActiveSheet.PageSetup
.PrintQuality = -3: .CenterHorizontally = False
.CenterVertically = False: .Orientation = xlLandscape
.Draft = False: .PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic: .Zoom = 100
.Zoom = False: .FitToPagesWide = 1
.FitToPagesTall = 1: .PrintErrors = xlPrintErrorsDisplayed
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\Schlandro\Desktop\PL.pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Call objWorkbook.Close(SaveChanges:=False)
Call Rows(1).AutoFilter(Field:=1, Criteria1:="PuL")
Range("A1:AS600").Select
Selection.Copy
Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)
With objWorkbook.Worksheets(1)
Call .Paste(Destination:=.Cells(1, 1))
End With
Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)
With objWorkbook.Worksheets(1)
Call .Paste(Destination:=.Cells(1, 1))
Rows("4:4").RowHeight = 32.25
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
End With
With ActiveSheet.PageSetup
.PrintQuality = -3: .CenterHorizontally = False
.CenterVertically = False: .Orientation = xlLandscape
.Draft = False: .PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic: .Zoom = 100
.Zoom = False: .FitToPagesWide = 1
.FitToPagesTall = 1: .PrintErrors = xlPrintErrorsDisplayed
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\Schlandro\Desktop\Pul.pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Call objWorkbook.Close(SaveChanges:=False)
Call Rows(1).AutoFilter(Field:=1, Criteria1:="PP")
Range("A1:AS600").Select
Selection.Copy
Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)
With objWorkbook.Worksheets(1)
Call .Paste(Destination:=.Cells(1, 1))
End With
Set objWorkbook = Workbooks.Add(Template:=xlWBATWorksheet)
With objWorkbook.Worksheets(1)
Call .Paste(Destination:=.Cells(1, 1))
Rows("4:4").RowHeight = 32.25
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
End With
With ActiveSheet.PageSetup
.PrintQuality = -3: .CenterHorizontally = False
.CenterVertically = False: .Orientation = xlLandscape
.Draft = False: .PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic: .Zoom = 100
.Zoom = False: .FitToPagesWide = 1
.FitToPagesTall = 1: .PrintErrors = xlPrintErrorsDisplayed
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\Schlandro\Desktop\PP.pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Call objWorkbook.Close(SaveChanges:=False)
End Sub
Vielen Dank für die Hilfe und liebe Grüße