vbamergems-wordmailmergedocx-mailmerge

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


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

Solution

  • 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