Save each page as it's own document titled as a value from the data source

Question

I have my document set up to automatically pull the data source for the mail merge.

From there, I'd like to save each page as it's own document and set the file name to one of the mail merge values.

Right now I do the mail merge and then go to "Finish & Merge" and then "Edit Individual Documents" before running a global (Normal) macro to save each page at the break but it's saving as Page1, Page2, etc.

I want to eliminate this step and only have to open the document, pull the data from the source by clicking yes and then run the macro from there and save each mail merge as it's own document.

Bonus points if it would be possible to automatically run the macro after the mail merge completes and not have to open the Macro window to launch the macro.

This is the script. I want to eliminate having to "Finish & Merge" "Edit Individual Documents.

Sub Separate_NEO_Letters()
    'Used to set criteria for moving through the document by section.
    Application.Browser.Target = wdBrowseSection

    'A mailmerge document ends with a section break next page.
    'Subtracting one from the section count stop error message.
    For i = 1 To ((ActiveDocument.Sections.Count) - 1)

        'Select and copy the section text to the clipboard
        ActiveDocument.Bookmarks("\Section").Range.Copy

        'Create a new document to paste text from clipboard.
        Documents.Add
        Selection.Paste

        'Removes the break that is copied at the end of the section, if any.
        Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
        Selection.Delete Unit:=wdCharacter, Count:=1

        ChangeFileOpenDirectory "S:\IT\NEO\Automation\Generated Letters"
        DocNum = DocNum + 1
        ActiveDocument.SaveAs FileName:="Page" & DocNum & ".doc"
        ActiveDocument.Close
        'Move the selection to the next section in the document
        Application.Browser.Next
    Next i
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub

See, for example *Send Mailmerge Output to Individual Files* in the **Mailmerge Tips and Tricks** thread at: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html — macropod, Nov 18 '20 at 20:31

score 0 · Accepted Answer · answered Nov 23 '20 at 14:50

With the help of macropod's commented link to an example, this is what I came up with.

I placed this in the ThisDocument and used Document_Open to automatically run and placed ActiveDocument.Save / Application.Quit in the script at the end so the file will run and then close since I don't actually need to do anything with the file once the letters have been generated.

This works great, especially since the script checks to see if a field is blank since I have an excel file I pull from that has 100 lines of prepopulated fields but this will only use those lines if the USERNAME data field is populated.

More than I could've hoped to accomplish, thanks macropod as well as http://msofficeforums.com >> https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html

Private Sub Document_Open()
' 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 & "\Generated Letters\"
  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("USERNAME")) = "" Then Exit For
        'StrFolder = .DataFields("Folder") & "\"
        StrName = .DataFields("USERNAME")
      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
 ActiveDocument.Save
 Application.Quit
End Sub

Save each page as it's own document titled as a value from the data source

1 Answers1