Public 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 & "\Email Attachments\"
  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("securitycode")) = "" Then Exit For
        StrName = "W-8BEN Form" & " - " & .DataFields("Portfoliocode") & " " & .DataFields("securitycode") & " " & .DataFields("name")
      End With
      .Execute Pause:=False
      If Err.Number = 5631 Then
        Err.Clear
        GoTo NextRecord
      End If
      For j = 1 To Len(StrNoChr)
        StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
      Next
      StrName = Trim(StrName)
      With ActiveDocument
        .SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
        .Close SaveChanges:=False
      End With
NextRecord:
    Next i
  End With
End With
Application.ScreenUpdating = True

MsgBox ("PDFs have been created.")
End Sub

Public Sub Merge_To_Individual_Files()
  Dim StrFolder As String, MainDoc As Document, i As Long
  Set MainDoc = ActiveDocument
  StrFolder = MainDoc.Path & "\"
  With MainDoc.MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    .ViewMailMergeFieldCodes = False
    With .DataSource
      .ActiveRecord = wdFirstRecord
      Do Until i = .ActiveRecord  'next record didn't go forward
        MainDoc.SaveAs FileName:=StrFolder & i & "temp.pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
        i = .ActiveRecord
        .ActiveRecord = wdNextRecord
      Loop
    End With
  End With
End Sub