stevembe
10-13-2016, 04:47 AM
I wonder if anybody can see what is wrong with the following code I am using. Basically it works perfectly splitting out a mail merge into separate documents and saving them to the path specified with name of file as text of 14th and 13th paragraph. However, each document has a graphic logo as a header which when 'unmerged' appears in every single document except the first. Any idea why this is happening?
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrTxt As String, Rng As Range, Doc As Document, HdFt As HeaderFooter
With ActiveDocument
'Process each Section
For i = 1 To .Sections.Count - 1
With .Sections(i)
'Get the 14th paragraph
Set Rng = .Range.Paragraphs(14).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct the destination file path & first part of name
StrTxt = "C:\Offers\Final\" & .Text & "_"
End With
'Get the 13th paragraph
Set Rng = .Range.Paragraphs(13).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct balance of file name
StrTxt = StrTxt & .Text & ".docx"
End With
'Get the whole Section
Set Rng = .Range
With Rng
'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(1).Headers
HdFt.Range.Copy
.Sections(1).Headers(HdFt.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
Next
For Each HdFt In Rng.Sections(1).Footers
HdFt.Range.Copy
.Sections(1).Footers(HdFt.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
Next
'Save & close the output document
.SaveAs FileName:=StrTxt, AddToRecentFiles:=False
.Close SaveChanges:=True
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrTxt As String, Rng As Range, Doc As Document, HdFt As HeaderFooter
With ActiveDocument
'Process each Section
For i = 1 To .Sections.Count - 1
With .Sections(i)
'Get the 14th paragraph
Set Rng = .Range.Paragraphs(14).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct the destination file path & first part of name
StrTxt = "C:\Offers\Final\" & .Text & "_"
End With
'Get the 13th paragraph
Set Rng = .Range.Paragraphs(13).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct balance of file name
StrTxt = StrTxt & .Text & ".docx"
End With
'Get the whole Section
Set Rng = .Range
With Rng
'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(1).Headers
HdFt.Range.Copy
.Sections(1).Headers(HdFt.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
Next
For Each HdFt In Rng.Sections(1).Footers
HdFt.Range.Copy
.Sections(1).Footers(HdFt.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
Next
'Save & close the output document
.SaveAs FileName:=StrTxt, AddToRecentFiles:=False
.Close SaveChanges:=True
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub