VBA Macro Help Required - Exporting to PDF AFTER Mail Merge

[Richard_Rich]

Hi all,

I appreciate this is quite a well travelled road for some and I'm aware of the works produced by Doug Robbins, Paul Epstein and Jie Jenn, but I'm still struggling.

I appreciate this may not be best practice, but I'm trying to:
1. split a mail merged document (post-merge) into individual PDF documents.
2. dictate the name of these individual documents from an excel datasheet
3. dictate the output of these documents from an excel datasheet (same as above)

I'm not precious about the code or structure if there is better logic to use, but I'd really appreciate guidance to get this working.

Please try not to laugh (or cry!), but below is the code I've put together and an attempt to explain my logic.

Thank you in advance.

Sub Merge_As_Individual_Documents ()

'Makes the code run faster and reduces screen flicker a bit.
Application.ScreenUpdating = False

' Select a folder, change the default file save location below so it's not just C:
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 = .DataFields("Output_Location")
 
ChangeFileOpenDirectory StrFolder

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

'Identify sections, 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

'As I'm post merge, select a template to use'

    Set oDoc = Documents.Add(Template:="C:\Program Files\Templates\Template_Blank.dotx", NewTemplate:=False, DocumentType:=0)
oDoc.Activate
        
    With oDoc
       ' Paste contents into the output document, preserving the formatting
      .Range.PasteAndFormat (wdFormatOriginalFormatting)
       ' Delete trailing paragraph breaks & page breaks at the end
      While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
        .Characters.Last.Previous = vbNullString
      Wend
       ' Replicate the headers & footers
      For Each HdFt In Rng.Sections(j).Headers
        .Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
      Next
      For Each HdFt In Rng.Sections(j).Footers
        .Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
      Next


       ' Save & close the output document
  
      .SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub

'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
 
' Build the filename from the spreadsheet merge fields
StrName = .DataFields("Datasource_Number") & "_" & .DataFields("First_Name") & "_" & .DataFields("Last_Name")
    
    ' Remove non-filename characters from the built name
      For j = 1 To Len(StrNoChr)
        StrTxt = Replace(StrName, Mid(StrNoChr, j, 1), "_")
      Next
    StrName = Trim(StrName)
    
   With ActiveDocument
      .SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
    
Application.Browser.Next
Next i
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End With
End Sub

 

[Macropod]

I suggest you visit the Mailmerge Tips & Tricks thread at Microsoft Office Forums - Word, Excel, Outlook, PowerPoint, Project and check out the topic:
• Split Merged Output to Separate Documents
Better still, check out the topics:
• Send Mailmerge Output to Individual Files; and
• Run a Mailmerge from Excel, Sending the Output to Individual Files;