Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 05-12-2019, 02:57 AM
FuriousD FuriousD is offline Windows 10 Office 2013
Novice
 
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

Hi,



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

http://www.msofficeforums.com/mail-m...ps-tricks.html

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?

Code:
Sub SplitMergedDocument()
' Sourced from: http://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
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), "_")
        Next
      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
        .Copy
      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
      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 & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
       ' and/or:
      .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

Thanks,
Reply With Quote
  #2  
Old 05-12-2019, 04:06 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
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
Default

Change:
Code:
Set Rng = .Range.Paragraphs(1).Range
to:
Code:
Set Rng = .Headers(wdHeaderFooterPrimary).Range.Paragraphs(1).Range
__________________
Cheers,
Paul Edstein
[MS MVP - Word]
Reply With Quote
Reply

Tags
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.
MSOfficeForums.com is not affiliated with Microsoft