How to split a mail merge and save files with a merge field as the name

Question

I have a bunch of mail merge templates setup, when I merge the documents I want to split the results into separate files each one with a name based on the merge field “FileNumber”.

The code I have currently is:

Sub splitter()
' Based on a macro by Doug Robbins to save each letter created by a mailmerge as a separate file.
' With help from http://www.productivitytalk.com/forums/topic/3927-visual-basic-question-for-merge-fields/

Dim i As Integer
Dim Source As Document
Dim Target As Document
Dim Letter As Range
Dim oField As Field
Dim FileNum As String

Set Source = ActiveDocument

For i = 1 To Source.Sections.Count
    Set Letter = Source.Sections(i).Range
    Letter.End = Letter.End - 1
        For Each oField In Letter.Fields
        If oField.Type = wdFieldMergeField Then
            If InStr(oField.Code.Text, "FileNumber") > 0 Then
            'get the result and store it the FileNum variable
            FileNum = oField.Result
            End If
        End If
        Next oField
    Set Target = Documents.Add
    Target.Range = Letter
    Target.SaveAs FileName:="C:\Temp\Letter" & FileNum
    Target.Close
    Next i
End Sub

The problem is if I “Merge to new document” then the “FileNumber” field no longer exists so it can’t pick that up but if I just go to “Preview Results” and run the macro it only saves the currently previewed record and not the rest of the letters.

I’m assuming I need to change the code to something like

For i = 1 To Source.MergedRecord.Count
    Set Letter = Source.MergedRecord(i).Range

but I can't work out the correct syntax.

I am aware of http://www.gmayor.com/individual_merge_letters.htm but I don't want the dialog boxes I just want a one click button.

Answer 1

In the Mail merge template document, paste the following macro code in "ThisDocument" module:

Dim WithEvents wdapp As Application
Dim bCustomProcessing As Boolean

Private Sub Document_Open()

Set wdapp = Application
bCustomProcessing = False
ThisDocument.MailMerge.DataSource.ActiveRecord = 1
ThisDocument.MailMerge.ShowWizard 1
With ActiveDocument.MailMerge
   If .MainDocumentType = wdFormLetters Then
       .ShowSendToCustom = "Custom Letter Processing"
   End If
End With

End Sub
Private Sub wdapp_MailMergeWizardSendToCustom(ByVal Doc As Document)

bCustomProcessing = True
Doc.MailMerge.Destination = wdSendToNewDocument
With Doc.MailMerge
    For rec = 1 To .DataSource.RecordCount
        .DataSource.ActiveRecord = rec
        .DataSource.FirstRecord = rec
        .DataSource.LastRecord = rec
        .Execute
    Next
End With

MsgBox "Merge Finished"
End Sub


Private Sub wdapp_MailMergeAfterMerge(ByVal Doc As Document, ByVal DocResult As Document)
If bCustomProcessing = True Then
    With Doc.MailMerge.DataSource.DataFields
        sFirmFileName = .Item(1).Value ' First Column of the data - CHANGE
    End With
    DocResult.SaveAs "c:\path\" & sFirmFileName & ".docx", wdFormatXMLDocument
     ' Path and File Name to save. can use other formats like wdFormatPDF too
    DocResult.Close False
End If
End Sub

Remember to update the column number to use for file names, and the path to save the generated files.

After writing this code, save and close the merge template doc. Re-open the file and this time you will be prompted with the Merge wizard. Proceed as required for the Letter, and at the last step, select "Custom Letter Processing" option instead of finishing merge. This will save the separate merged docs in specified folder.

Please remember that this code can be heavy on the processor.