Sub SplitMergedDocument()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Const StrNoChr As String = """*./\:?|"
j = InputBox("How many Section breaks are there per record?", "Split By Sections", 1)
With ActiveDocument
   ' Process each Section
  For i = 1 To .Sections.Count - 1 Step j
    With .Sections(i)
       '*****
       ' Get the 1st paragraph's text
      StrTxt = Split(.Range.Paragraphs(1).Range.Text, vbCr)(0)
      For k = 1 To Len(StrNoChr)
        StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
      Next
       ' Construct the destination file path & name
      StrTxt = ActiveDocument.Path & "\" & StrTxt
       '*****
       ' Get the whole Section
      Set Rng = .Range
      With Rng
        If j > 1 Then .MoveEnd wdSection, j - 1
         'Contract the range to exclude the Section break
        .MoveEnd wdCharacter, -1
         ' Copy the range
        .Copy
      End With
    End With
     ' Create the output document
    Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
    With Doc
       ' Paste contents into the output document, preserving the formatting
      .Range.PasteAndFormat (wdFormatOriginalFormatting)
       ' Delete trailing paragraph breaks & page breaks at the end
      While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
        .Characters.Last.Previous = vbNullString
      Wend
       ' Replicate the headers & footers
      For Each HdFt In Rng.Sections(j).Headers
        .Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
      Next
      For Each HdFt In Rng.Sections(j).Footers
        .Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
      Next
       ' Save & close the output document
      .SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
       ' and/or:
      .SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub

Sub Merge_To_Individual_Files()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
  StrFolder = .Path & "\"
  With .MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    On Error Resume Next
    For i = 1 To .DataSource.RecordCount
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
        'If Trim(.DataFields("Last_Name")) = "" Then Exit For
        'StrFolder = .DataFields("Folder") & "\"
        StrName = .DataFields("AFilename") & "_" '& .DataFields("First_Name")
      End With
      On Error GoTo NextRecord
      .Execute Pause:=False
      For j = 1 To Len(StrNoChr)
        StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
      Next
      StrName = Trim(StrName)
      With ActiveDocument
        'Add the name to the footer
        '.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
        .SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
        ' and/or:
        .SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
        .Close SaveChanges:=False
      End With
NextRecord:
    Next i
  End With
End With
Application.ScreenUpdating = True
End Sub