Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 05-12-2019, 02:57 AM
FuriousD FuriousD is offline Mail Merge - split merged documents and rename each split document based on text in header Windows 10 Mail Merge - split merged documents and rename each split document based on text in header Office 2013
Novice
Mail Merge - split merged documents and rename each split document based on text in header
 
Join Date: May 2019
Posts: 1
FuriousD is on a distinguished road
Default Mail Merge - split merged documents and rename 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:

https://www.msofficeforums.com/mail-...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: https://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 Mail Merge - split merged documents and rename each split document based on text in header Windows 7 64bit Mail Merge - split merged documents and rename each split document based on text in header Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Change:
Code:
Set Rng = .Range.Paragraphs(1).Range
to:
Code:
Set Rng = .Headers(wdHeaderFooterPrimary).Range.Paragraphs(1).Range
__________________
Cheers,
Paul Edstein
[Fmr 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
Mail Merge - split merged documents and rename each split document based on text in header split word document based on bookmarks with each new document title of the bookmark megatronixs Word VBA 9 09-05-2020 02:29 PM
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
Mail Merge - split merged documents and rename each split document based on text in header Split each page of mail merge into separate pdf Declan Mail Merge 1 05-28-2014 02:02 AM
Mail Merge - split merged documents and rename each split document based on text in header Split multi-page mail merge document, then name file from letter info. BriMan83 Mail Merge 1 04-24-2013 11:35 PM
Mail Merge - split merged documents and rename each split document based on text in header Automatically split Mail Merge based on number of pages SaneMan Mail Merge 1 12-03-2011 01:11 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 10:46 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft