AW: Ein PDF aus mehreren Exceldateien generieren
10.03.2016 10:16:08
Michael
Hallo Frank!
Beverlys Vorgehensweise als Makro:
Sub PdfSammlung()
Dim SuchDialog As FileDialog
Dim Pfad As String
Dim Datei As String
Dim QuellMappe As Workbook
Dim ZielMappe As Workbook
Application.ScreenUpdating = False
Set ZielMappe = Workbooks.Add
'Auswahl-Dialog für durchsuchtes Verzeichnis
Set SuchDialog = Application.FileDialog(msoFileDialogFolderPicker)
With SuchDialog
.Title = "Bitte Verzeichnis wählen"
.AllowMultiSelect = False
If .Show -1 Then
MsgBox "Vorgang abgebrochen", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1) & "\"
End If
End With
'Durchlaufen der .xlsx-Dateien im o.a. Verzeichnis
Datei = Dir(Pfad & "*.xlsx", vbDirectory)
'Abbruch wenn keine .xlsx-Dateien im o.a. Verzeichnis sind
If Len(Datei) = 0 Then
MsgBox "Keine [.xlsx] vorhanden. Abbruch!"
Exit Sub
End If
'Mappen in ausgewählten Verzeichnis nacheinander öffnen
'Jeweils erstes Blatt in neue Mappe kopieren
Do While Len(Datei) > 0
Set QuellMappe = Workbooks.Open(Filename:=Pfad & Datei)
With QuellMappe
.Worksheets(1).Copy _
after:=ZielMappe.Worksheets(ZielMappe.Worksheets.Count)
.Close savechanges:=False
End With
Datei = Dir
Loop
'Neue Mappe als PDF-Speichern und Mappe verwerfen
'Pdf wird angezeigt und als "Export.pdf" im o.a. Pfad gespeichert
With ZielMappe
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Pfad & "Export.pdf", _
ignoreprintareas:=False, openafterpublish:=True
.Close savechanges:=False
End With
'Aufräumen
Set QuellMappe = Nothing
Set ZielMappe = Nothing
Set SuchDialog = Nothing
Application.ScreenUpdating = True
End Sub
LG
Michael