VBA Excel Makro - Serienbrief in Word aus Excel starten und anschließend einzeln speichern

Private Const strDatenquelle As String = "C:\Test\Serienbrief\Datenquellen\Test_Beispiel_Serienbrief.xlsx"  
Private Const strWordVorlage As String = "C:\Test\Serienbrief\SerienbriefBeispiel Test_Vorlage_IR.docx"  

Sub Serienbrief()
    
    Dim Bereich As Range
    Dim wb As Workbook, wbAlle As Workbook
    
    Application.ScreenUpdating = False
    
    ' Datei mit allen Daten, auch ältere Daten wird geöffnet  
    Set wbAlle = Workbooks.Open(Filename:="C:\Test\Serienbrief\Datenquellen\Test_Beispiel_" & Format(Date, "yyyy_mm_dd") & ".xlsx")  
    
    Set Bereich = Range("A1:BH65536")                           ' Bereich mit Serienbrief-Daten  
    Set wb = Workbooks.Open(Filename:=strDatenquelle)           ' Datei bzw. Datenquelle mit aktuellen Daten für den Serienbrief  

    ' Altdaten aus der Datenquelle für den Serienbrief löschen  
    
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select  
    
    'neue Daten reinkopieren  
    
    Bereich.Copy Destination:=Cells(1, 1)
    
    'Dateien Speichern bzw. schliessen  
    
    wb.Save
    wb.Close
    wbAlle.Close
        
    Application.ScreenUpdating = True
    
    Call Serienb

End Sub

Sub Serienb()
  
  ' Im Excel VBA-Editor muss vorher für die Datei mit diesem Makro unter Extras-Verweise  
  ' den Verweis auf die Microsoft Word x.y Object Library aktiviert werden!!  
  
  Dim WinWord, WinDoc As Word.Document, docSerienbrief As Word.Document
  Dim sFile As String, strCon As String
      
  sFile = strWordVorlage
  
  Set WinWord = CreateObject("Word.Application")  
  
  With WinWord
        .Visible = True
    
    '   Vorlagedatei öffnen  
    
    Set WinDoc = .Documents.Open(sFile)
    
    With WinDoc
      
      With .MailMerge
    
    '   Datenquelle öffnen  
        
        .OpenDataSource Name:=strDatenquelle, _
          ConfirmConversions:=False, _
          LinkToSource:=True, _
          Revert:=False, _
          Format:=wdOpenFormatAuto, _
          Connection:="Provider=Microsoft.Jet.OLEDB.4.0;" _  
            & "User ID=Admin;" _  
            & "Data Source=" & strDatenquelle & ";" _  
            & "Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";" _  
            & "Jet OLEDB:System database="""";" & "Jet OLEDB:Registry Path="""";" _  
            & "Jet OLEDB:Engine ", _  
          SQLStatement:="SELECT * FROM `Tabelle1$`", SQLStatement1:="", _  
          SubType:=wdMergeSubTypeAccess
    
    '   Serienbrief mit allen Daten im neuen Dokument erstellen  
        
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
          .FirstRecord = wdDefaultFirstRecord
          .LastRecord = wdDefaultLastRecord
        End With
           
        .Execute Pause:=False
        Set docSerienbrief = WinWord.ActiveDocument

    '   Datenquelle wieder schliessen  
        
        .DataSource.Close
      End With

    '   Vorlagedatei wieder schliessen  
      
      .Close Savechanges:=False
    End With

    '   Serienbrief - Drucken - Seitenvorschau  
    
    docSerienbrief.Application.WindowState = wdWindowStateMinimize
    If MsgBox("Alle Briefe aus dem Serienbrief Drucken?", vbYesNo + vbQuestion, _  
        "Serienbrief-Erstellung - Drucken - Seitenvorschau") = vbYes Then  
        docSerienbrief.Application.WindowState = wdWindowStateMaximize
        docSerienbrief.PrintPreview
    '   docSerienbrief.PrintOut  
    End If

    '   Serienbrief - Speichern  
    
    docSerienbrief.Application.WindowState = wdWindowStateMinimize
    If MsgBox("Serienbrief als Gesamtdokument Speichern?", vbYesNo + vbQuestion, _  
        "Serienbrief-Erstellung-Speichern") = vbYes Then  
        docSerienbrief.Application.WindowState = wdWindowStateMaximize
        docSerienbrief.SaveAs Filename:="C:\Test\Serienbrief\Druck\Test_Beispiel_Alle_" & Format(Date, "yyyy_mm_dd") & ".docx"  
        'docSerienbrief.Application.Dialogs(wdDialogFileSaveAs).Show  
    End If
    docSerienbrief.Application.WindowState = wdWindowStateMaximize
    
  docSerienbrief.Close
    
  End With
      
  Set docSerienbrief = Nothing
  Set WinWord = Nothing
  Set WinDoc = Nothing

  Call SerienbSaveAsSingleDocs

End Sub

Sub SerienbSaveAsSingleDocs()

    Dim strDatenquelle As String, strFilenameDOCX As String, strFilenamePDF As String, sFile As String
    Dim i As Long
    Dim WinWord, WinDoc As Word.Document

    sFile = strWordVorlage
    
    Set WinWord = CreateObject("Word.Application")  
    
    ' Ausgabepfad  

    Const OUTPUTPATH = "C:\Test\Serienbrief\Druck"  

    ' Datenquelle  

    'strDatenquelle = "D:\Daten\datenquelle.xlsx"  

    ' Screenupdating deaktivieren  

    Application.ScreenUpdating = False

    Set WinDoc = WinWord.Documents.Open(sFile)

    With WinDoc.MailMerge

        'Dokumenttyp festlegen  

        .MainDocumentType = wdFormLetters

        'Datenquelle öffnen  

        .OpenDataSource Name:=strDatenquelle, Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & strDatenquelle & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Locking Mode=0;Jet OL", SQLStatement:="SELECT * FROM `Tabelle1$`", SQLStatement1:="", SubType:=wdMergeSubTypeAccess  

        'Datensätze sollen in neuen Dokumenten laden  

        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True

        'Führe folgende Aktionen für jeden Datensatz der Datenquelle durch.  

        For i = 1 To .DataSource.RecordCount

            'Datenquelle auf aktuellen Datensatz beschränken  

            With .DataSource
                .FirstRecord = i
                .LastRecord = i
                .ActiveRecord = i

                'Dateinamen für DOCX und PDF zusammenbauen  

                strFilenameDOCX = Format(Date, "yyyyMMdd") & "_" & .DataFields("Vorname1").Value & "_" & .DataFields("Nachname").Value & "_Test.docx"  
                strFilenamePDF = Format(Date, "yyyyMMdd") & "_" & .DataFields("Vorname1").Value & "_" & .DataFields("Nachname").Value & "_Test.pdf"  
            End With

            'Mailmerge für aktuellen Datensatz ausführen  

            .Execute Pause:=False

            ' Dokument des aktuellen Datensatzes  

            With ActiveDocument

                ' Speichern als DOCX  

                .SaveAs2 OUTPUTPATH & "\" & strFilenameDOCX  

                'Speichern als PDF  

                .ExportAsFixedFormat OUTPUTPATH & "\" & strFilenamePDF, wdExportFormatPDF  

                'Dokument schließen  

                .Close False
            End With
        Next
    End With

    'Screenupdating aktivieren  

    Application.ScreenUpdating = True

End Sub