Sub RunMerge()
' Merges one record at a time to the folder containing the Excel workbook.
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
' Note: this code requires a reference to the Word object model to be set, via Tools|References in the VBE.
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String
Dim i As Long, j As Long: Const StrNoChr As String = """*./\:?|"
StrMMSrc = ThisWorkbook.FullName: StrMMPath = ThisWorkbook.Path & "\": StrMMDoc = StrMMPath & "abc.docx"
Dim wdApp As New Word.Application, wdDoc As Word.Document
With wdApp
  .Visible = True
  .DisplayAlerts = wdAlertsNone
  Set wdDoc = .Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
  With wdDoc
    With .MailMerge
      .MainDocumentType = wdFormLetters
      .OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
        LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
        "Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
        SQLStatement:="SELECT * FROM `Sheet1$` WHERE Anz > 0"
      For i = 1 To .DataSource.RecordCount
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
          .FirstRecord = i
          .LastRecord = i
          .ActiveRecord = i
          If Trim(.DataFields("ID")) = "" Then Exit For
          StrName = .DataFields("ID")
        MsgBox StrName
        End With
        .Execute Pause:=False
        For j = 1 To Len(StrNoChr)
          StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
        Next
        StrName = Trim(StrName)
        MsgBox StrName
        MsgBox StrMMPath & i & "_" & StrName
        With wdApp.ActiveDocument
          .SaveAs Filename:=StrMMPath & i & "_" & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
          ' and/or:
          '.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
          .Close SaveChanges:=False
        End With
      Next i
      .MainDocumentType = wdNotAMergeDocument
    End With
    .Close SaveChanges:=False
  End With
  .DisplayAlerts = wdAlertsAll
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = False
End Sub