AW: Mehrere Dateien in PDF speichern VBA
09.03.2017 16:51:21
Herbert
Hallo Philipp,
probier's mal damit:
Den Code in ein StandardModul ("Modul1" etc.) kopieren und den Pfad ("D:\xxx") anpassen.
Option Explicit
Option Compare Text
Private lRowCounter As Long
Private oSheet As Object
Const sRootPath As String = "D:\xxx" '* Pfad bitte anpassen ohne "\" am Ende!!!
Sub DateienAusVerzeichnis_Auflisten()
Dim sWorkBookName$, vFile As Variant, sPath$, iLastRow%, iRowsCount%, sFileName$
On Error GoTo ende
Application.EnableEvents = False
Application.ScreenUpdating = False
Sheets.Add
ActiveSheet.Name = "TabelleZwi"
Set oSheet = Sheets("TabelleZwi")
oSheet.Activate
oSheet.Cells(1, 1).Select
lRowCounter = 1
Call ReadFolder(sRootPath)
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For iRowsCount = 1 To iLastRow
sFileName = Cells(iRowsCount, 1).Value
sFileName = sRootPath & "\" & sFileName
Workbooks.Open sFileName
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sFileName & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
ActiveWorkbook.Close savechanges:=False
Next
Application.DisplayAlerts = False
oSheet.Delete
Application.DisplayAlerts = True
ende:
Set oSheet = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub ReadFolder(ByVal sPath As String)
Dim oFSO As Object, oFolder As Object, oFile As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder(sPath)
With oSheet
'* Alle Dateien/Files auflisten
For Each oFile In oFolder.Files
If VBA.Left(oFile.Name, 1) "~" Then .Cells(lRowCounter, 1) = oFile.Name
lRowCounter = lRowCounter + 1
Next oFile
End With
Set oFSO = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
Nicht vergessen, den Pfad, ganz oben ("D:\xxx"), anpassen!!!
Servus