Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

LinkBack Thread Tools Display Modes
Old 05-12-2019, 02:57 AM
FuriousD FuriousD is offline Windows 10 Office 2013
Join Date: May 2019
Posts: 1
FuriousD is on a distinguished road
Default Mail Merge - split merged documents and reanme each split document based on text in header


I've used the following macro to split a merged word document. that I found on this site:

It looks at the first paragraph to rename each file.
I have a unique reference in the header field.
How can I adjust this macro to rename each split document based on the text in the header?

Sub SplitMergedDocument()
' Sourced from:
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Const StrNoChr As String = """*./\:?|"
j = InputBox("How many Section breaks are there per record?", "Split By Sections", 1)
With ActiveDocument
   ' Process each Section
  For i = 1 To .Sections.Count - 1 Step j
    With .Sections(i)
       ' Get the 1st paragraph
      Set Rng = .Range.Paragraphs(1).Range
      With Rng
        ' Contract the range to exclude the final paragraph break
        .MoveEnd wdCharacter, -1
        StrTxt = .Text
        For k = 1 To Len(StrNoChr)
          StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
      End With
       ' Construct the destination file path & name
      StrTxt = ActiveDocument.Path & Application.PathSeparator & StrTxt
       ' Get the whole Section
      Set Rng = .Range
      With Rng
        If j > 1 Then .MoveEnd wdSection, j - 1
         'Contract the range to exclude the Section break
        .MoveEnd wdCharacter, -1
         ' Copy the range
      End With
    End With
     ' Create the output document
    Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
    With Doc
       ' 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
       ' Replicate the headers & footers
      For Each HdFt In Rng.Sections(j).Headers
        .Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
      For Each HdFt In Rng.Sections(j).Footers
        .Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
       ' Save & close the output document
      .SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
       ' and/or:
      .SaveAs FileName:=StrTxt & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub

Reply With Quote
Old 05-12-2019, 04:06 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 19,392
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold

Set Rng = .Range.Paragraphs(1).Range
Set Rng = .Headers(wdHeaderFooterPrimary).Range.Paragraphs(1).Range
Paul Edstein
[MS MVP - Word]
Reply With Quote

vba code, word 2013 problem

Thread Tools
Display Modes

Similar Threads
Thread Thread Starter Forum Replies Last Post
Help Please: New VBA user trying to use a macro to split Mail Merge documents. Two Run-Time Error zipit189 Word VBA 7 03-18-2015 01:13 PM
Split each page of mail merge into separate pdf Declan Mail Merge 1 05-28-2014 02:02 AM
split word document based on bookmarks with each new document title of the bookmark megatronixs Word VBA 8 06-03-2013 08:16 PM
Split multi-page mail merge document, then name file from letter info. BriMan83 Mail Merge 1 04-24-2013 11:35 PM
Automatically split Mail Merge based on number of pages SaneMan Mail Merge 1 12-03-2011 01:11 AM

All times are GMT -7. The time now is 10:52 PM.

Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc. is not affiliated with Microsoft