See http://www.gmayor.com/individual_merge_letters.htm the add-in there will
merge to separate PDFs. A separate merge to a new document would create the
single merge document.

--

Graham Mayor - Word MVP

My web site www.gmayor.com
Word MVP web site http://word.mvps.org



Martin wrote:
Hi all,

I am using the code below to run on events during a Word mailmerge.
The code splits to individual Word and PDF files, it works fine but I
only need to split the documents into individual PDF files then leave
one single merged Word document. Any help is appreciated.

Thanks.

Option Explicit
Public docMergeResult As Document
Public MainDoc As Document
Dim AppClass As New MergeApplication

Public Sub AutoExec()
Set AppClass.app = Word.Application
End Sub

Sub ActivateEvents()
Set AppClass.app = Word.Application
End Sub

Sub DeactivateEvents()
Set AppClass.app = Nothing
End Sub

Sub DeleteResultsDocument()
docMergeResult.Close wdDoNotSaveChanges
End Sub

Code in class module

Option Explicit
Public SettingsFile As String
Public WithEvents app As Word.Application
Public Flag As Boolean, Fieldnum As Long, FFName As String, FldrPath
As String, j As Long, n As Long, Fname As String, Fsname As String,
fnames As Variant, i As Long, k As Long

Private Sub app_MailMergeAfterMerge(ByVal Doc As Document, ByVal
DocResult As Document)
SettingsFile = Options.DefaultFilePath(wdDocumentsPath) &
"\Settings.txt"
Doc.Activate
Dim olds, news As Integer, hf As HeaderFooter, oe As Boolean
Dim MakePDF As Boolean
MakePDF = False
If System.PrivateProfileString(SettingsFile, "MacroSettings",
"MakePDF") = "True" Then
MakePDF = True
Dim printer As String
With Dialogs(wdDialogFilePrintSetup)
printer = .printer
.printer = "Adobe PDF"
.Execute
End With
End If
If Flag = True Then
fnames = Split(Fname, "#")
For i = 0 To UBound(fnames)
For j = i + 1 To UBound(fnames)
If fnames(i) = fnames(j) Then
If Right(Left(fnames(j), InStr(fnames(j), ".") -
1), 1) = ")" Then
k = Val(Right(Left(fnames(j), InStr(fnames(j),
".") - 2), 1)) + 1
fnames(j) = Left(fnames(j), InStr(fnames(j),
".") - 4) & "(" & k & ").doc"
Else
fnames(j) = Left(fnames(j), InStr(fnames(j),
".") - 1) & "(1).doc"
End If
' MsgBox "The merge cannot be perfomed to separate
documents because" & vbCr & "the mergefield that you have selected to
supply the filenames" & vbCr & "contains identical information in two
or more records."
' Set docMergeResult = Documents(DocResult.Name)
' Application.OnTime Now, "DeleteResultsDocument"
' Application.ScreenUpdating = True
' Exit Sub
End If
Next j
Next i
If Doc.PageSetup.OddAndEvenPagesHeaderFooter = True Then
oe = True
End If
Dim NewDoc As Document, drange As Range, drange2 As Range
Set MainDoc = Documents(Doc.name)
For i = 0 To j - 1
Set drange = DocResult.Range
drange.End = DocResult.Sections(n).Range.End
Set NewDoc = Documents.Add(Visible:=False)
NewDoc.Range.FormattedText = drange.FormattedText
olds = NewDoc.Sections.Count - 1
news = NewDoc.Sections.Count
If oe = True Then
NewDoc.PageSetup.OddAndEvenPagesHeaderFooter = True
End If
If
NewDoc.Sections(olds).PageSetup.DifferentFirstPage HeaderFooter = True
Then

NewDoc.Sections(news).PageSetup.DifferentFirstPage HeaderFooter = True
End If
If oe = True Then
NewDoc.PageSetup.OddAndEvenPagesHeaderFooter = True
End If
For Each hf In NewDoc.Sections(news).Headers
hf.LinkToPrevious = True
Next
For Each hf In NewDoc.Sections(news).Footers
hf.LinkToPrevious = True
Next

NewDoc.Sections(NewDoc.Sections.Count).PageSetup.S ectionStart =
wdSectionContinuous NewDoc.Range.Fields.Update
NewDoc.SaveAs FldrPath & fnames(i)
If MakePDF = True Then
NewDoc.PrintOut Background:=False
End If
NewDoc.Close wdDoNotSaveChanges
Set NewDoc = Nothing
drange.Delete
Next i
Set docMergeResult = Documents(DocResult.name)
Application.OnTime Now, "DeleteResultsDocument"
Application.ScreenUpdating = True
If MakePDF = True Then
With Dialogs(wdDialogFilePrintSetup)
.printer = printer
.Execute
End With
End If
Else
DocResult.Activate
End If

End Sub

Private Sub app_MailMergeAfterRecordMerge(ByVal Doc As Document)
Dim MissingRecord As String
Dim Msg, Style, Title, Response
MissingRecord = ""
If Flag = True Then
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
k = 1
End If
With Doc.MailMerge.DataSource
Fsname = .DataFields(FFName).Value
If Trim(Fsname) = "" Then
For i = 1 To .DataFields.Count
MissingRecord = MissingRecord & .DataFields(i).name &
" = " & .DataFields(i).Value & vbCr
Next i
Msg = "There is no data in the field for filename for the
record containing " & vbCr & vbCr & MissingRecord & vbCr
Msg = Msg & "To enter a filename, click Yes. If you click
No, the document will be named NoNameNumber#"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "Missing Filename"
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
Fsname = InputBox("Enter the filename for the record
containing " & vbCr & vbCr & MissingRecord, "Enter the Filename")
If Trim(Fsname) = "" Then
Fsname = "NoNameNumber" & k
k = k + 1
End If
Else
Fsname = "NoNameNumber" & k
k = k + 1
End If
End If
If UCase(Right(Fsname, 4)) = ".DOC" Then
Fsname = Left(Fsname, Len(Fsname) - 4) & ".doc"
Else
Fsname = Fsname & ".doc"
End If
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
Fname = Fsname
j = 1
Else
Fname = Fname & "#" & Fsname
j = j + 1
End If
End With
End If
End Sub

Private Sub app_MailMergeBeforeRecordMerge(ByVal Doc As Document,
Cancel As Boolean)
SettingsFile = Options.DefaultFilePath(wdDocumentsPath) &
"\Settings.txt"
If Doc.MailMerge.DataSource.ActiveRecord =
Doc.MailMerge.DataSource.FirstRecord Then
n = Doc.Sections.Count - 1
Flag = False
If Doc.MailMerge.Destination = 0 Then
Dim intVBAnswer As Integer
'Request whether the user wants to create a separate
document for each record.
intVBAnswer = MsgBox("Do you want to create a separate PDF
document for each record?", vbYesNo, "Merge to Document")
If intVBAnswer = vbYes Then
'Display a form containing the mergefields
'for the user to select the field containing the
filenames. Dim oform As frmShowMergeFields
Set oform = New frmShowMergeFields
Dim fld As Word.MailMergeDataField
For Each fld In Doc.MailMerge.DataSource.DataFields
oform.lstMergeFields.AddItem fld.name
Next fld
oform.txtFldrPath.Text =
System.PrivateProfileString(SettingsFile, "MacroSettings", "FldrPath")
oform.Show vbModal
If Trim(System.PrivateProfileString(SettingsFile,
"MacroSettings", "mmfilefield")) "" Then
FFName = System.PrivateProfileString(SettingsFile,
"MacroSettings", "mmfilefield")
Flag = True
Set oform = Nothing
FldrPath =
Trim(System.PrivateProfileString(SettingsFile, "MacroSettings",
"FldrPath")) 'Else
'The user pressed Cancel in the Userform
'Flag = False
'Set oform = Nothing
'MsgBox "You have cancelled the process. The
merge will be executed to a single document."
'Exit Sub
End If
End If
End If
End If
End Sub