Guten Morgen zusammen,
ist es möglich diesen Code so anzupassen, dass ein gesamter Inhalt aus einem Ordner an PDFs zusammengeführt wird?
Option Explicit
Sub multidoc()
Dim fso As Object, WshShell As Object
Dim strOrdner As String, i As Long
Dim strMulti As String, strCommand As String, strGS As String
Set fso = CreateObject("Scripting.FileSystemObject")
'Pfad zu gswin32c.exe anpassen
strGS = "C:\Programme\Textbearbeitung\Ghostscript\gs8.53\bin\gswin32c.exe"
'Ausgabeordner anpassen
strOrdner = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3") & Format(Date, "YYYY-MM-DD") & "\"
With JUBILARE_DBASE 'anpassen
'Spalte A : Dateinamen mit komplettem Pfad
'Spalte B : Dateinamen mit komplettem Pfad
For i = 2 To .UsedRange.Rows.Count
If fso.FileExists(.Cells(i, 1).Value) And fso.FileExists(.Cells(i, 2).Value) Then
strMulti = " " & Chr(34) & .Cells(i, 1).Value & Chr(34) & " " & Chr(34) & .Cells(i, 2).Value & Chr(34)
strOrdner = fso.getfolder(strOrdner).ShortPath
strGS = fso.GetFile(strGS).ShortPath
strCommand = strGS & " -q -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=" & Chr(34)
strCommand = strCommand & strOrdner & "\"
'Name der Ausgabedatei = Name der Datei in der Spalte A
strCommand = strCommand & fso.GetFile(.Cells(i, 1).Value).Name & Chr(34) & strMulti
Debug.Print strCommand
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run strCommand, 0, True
Set WshShell = Nothing
End If
Next
End With
Set fso = Nothing
MsgBox "Fertig"
End Sub
Der Inhalt befindet sich im Pfad des strOrdner - wo auch die zusammengeführte Datei hinsollte.
Die einzelnen Dateien werden mittels folgendem Code abgelegt:
Aus Tabellenblatt:
Private Sub CommandButton5_Click()
Dim lngLletzte As Long
Dim lngZeile As Long
Dim strPfad As String
strPfad = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3")
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If MsgBox("Bist du sicher, dass du mit dem Export des Serienbriefs beginnen willst?", vbExclamation + vbYesNo) = vbYes Then
If Dir(strPfad & Format(Date, "YYYY-MM-DD"), vbDirectory) = "" Then
MkDir strPfad & Format(Date, "YYYY-MM-DD")
End If
With ThisWorkbook.Worksheets("JUBILARE_DBASE")
'letzte beschriebene Zeile ermittlen
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
'alle Zeilen durchlaufen
For lngZeile = 6 To lngLetzte
'Prüfen ob Gewerbliche oder Angestellte sowie und nur für ausgewählten Monat ausführen!
If .Cells(lngZeile, 14).Value = .Range("C3") Then Call PDFSerienSpeichern(lngZeile)
Next lngZeile
MsgBox "Die Urkunden wurden gespeichert!"
End With
Else
MsgBox "Du hast das Makro abgebrochen!"
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Im Modul:
Sub PDFSerienSpeichern(lngZeile As Long)
Dim strPfad As String
Dim Dateiname As String
Dim OpenPDF As String
Dim Entry As String
If Sheets("JUBILARE_DBASE").Cells(lngZeile, 6).Value <> "" Then Entry = Sheets("JUBILARE_DBASE").Cells(lngZeile, 6).Value Else Entry = Sheets("JUBILARE_DBASE").Cells(lngZeile, 7).Value
Sheets("JUBILARE_Urkunde").Range("B16").Value = Sheets("JUBILARE_DBASE").Cells(lngZeile, 2).Value & " " & Sheets("JUBILARE_DBASE").Cells(lngZeile, 3).Value
Sheets("JUBILARE_Urkunde").Range("B19").Value = Entry
Sheets("JUBILARE_Urkunde").Range("A15").Value = Sheets("JUBILARE_DBASE").Cells(lngZeile, 15).Value
strPfad = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3") & Format(Date, "YYYY-MM-DD") & "\"
Dateiname = ThisWorkbook.Worksheets("JUBILARE_Urkunde").Range("B19").Value & " - JUBILAR - " & ThisWorkbook.Worksheets("JUBILARE_Urkunde").Range("B16").Value
ChDir strPfad
ThisWorkbook.Worksheets("JUBILARE_Urkunde").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strPfad & Dateiname & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True _
, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub
Vielen Dank für Eure Hilfen.
VG