Try the following macro - it's based on one in my
Mailmerge Tips & Tricks thread (
https://www.msofficeforums.com/mail-...ps-tricks.html):
Code:
Sub Merge_To_Individual_Files()
' Merges one record at a time to the folder containing the mailmerge main document.
' Based on: 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, Tbl As Table
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & Application.PathSeparator
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Contact1")) = "" Then Exit For
StrName = .DataFields("Contact1")
End With
.Execute Pause:=False
End With
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = "Letter1 - " & Trim(StrName)
With ActiveDocument
For Each Tbl In .Tables
With Tbl
For j = .Rows.Count To 1 Step -1
If Trim(Split(.Cell(j, 1).Range.Text, vbCr)(0)) = "$" Then .Rows(j).Delete
Next
End With
Next
.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
Next i
End With
Application.ScreenUpdating = True
End Sub