70 Aufrufe
Gefragt in Tabellenkalkulation von marc1984 Einsteiger_in (47 Punkte)

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 

1 Antwort

0 Punkte
Beantwortet von m-o Profi (19.5k Punkte)

Hallo,

kopiere das folgende Makro in ein allgemeines Modul:

Sub PDF_Merge()
Dim strPfad As String
Dim strGS As String
Dim strPDF As String
Dim strDatname As String
Dim strCommand As String
Dim t As Variant

'Pfad für Ghostscript - ggf. anpassen
strGS = "C:\Programme\Textbearbeitung\Ghostscript\gs8.53\bin\gswin32c.exe"

'Verzeichnis auswählen, in dem die PDFs stehen, die zusammengefügt werden sollen
strPfad = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3") & Format(Date, "YYYY-MM-DD") & "\"
'PDF-Dateien aus Verzeichnis einlesen
strDatname = Dir(strPfad & "*.pdf")

'Schleife zum einlesen aller entsprechenden Dateien
Do While Len(strDatname)

   'Dateiname eintragen:
   'Prüfen, ob Leerzeichen im Dateinamen existiert
   If InStr(strDatname, " ") Then
     'falls ja, muss der Dateiname in Anführungszeichen gesetzt werden
     strPDF = strPDF & " """ & strPfad & strDatname & """"
    Else
     'falls nein, reicht die einfache Übername des eingelesenen Namens
     strPDF = strPDF & " " & strPfad & strDatname
   End If

   strDatname = Dir

Loop

'für Ghostscript den Befehl erstellen
strCommand = strGS & " -dNOPAUSE -sDEVICE=pdfwrite -sOutputFile=" & strPfad & "Merged.pdf -dBATCH" & strPDF

'Ghostscript-Befehl ausführen
t = Shell(strCommand, 0)

'Abschlussmeldung
MsgBox "Alle Dateien im ausgewählten Verzeichnis wurden zusammengefügt", 48, "Zusammenfügen beendet"

End Sub

Der Name der zusammengefügten Datei lautet "Merge.pdf". Die PDF-Dateien werden in der Reihenfolge, in der sie eingelesen werden zusammengefügt. Beachte bitte, dass es nach der Abschlussmeldung etwas dauern kann, bis die PDF-Datei erstellt und in das Verzeichnis geschrieben wird.

Sollte es bereits eine PDF-Datei mit dem Namen Merged.pdf geben, wird diese ohne Rückfrage überschrieben.

Gruß

M.O.

...