stevembe
03-17-2015, 01:23 AM
I am hoping somebody can help modify a bit of script I have used in the past but it is now not funtioning correctly. Basically the following unmerged word letters and saved them to a specified path and named them automatically. However, the format of the document I am using has changed. There are now 4 paragraph breaks then a table and after that a Section Break (Continuous) and at the bottom of the page a Section Break (Next Page) which is where I want the unmerge to stop and save
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 = 2 To .Sections.Count - 2
With .Sections(i)
'Get the 6th paragraph
Set Rng = .Range.Paragraphs(6).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct the destination file path & first part of name
StrTxt = "H:\Terms & Conditions\Final\" & .Text & "_"
End With
'Get the 5th paragraph
Set Rng = .Range.Paragraphs(5).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
Most grateful for any help
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 = 2 To .Sections.Count - 2
With .Sections(i)
'Get the 6th paragraph
Set Rng = .Range.Paragraphs(6).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct the destination file path & first part of name
StrTxt = "H:\Terms & Conditions\Final\" & .Text & "_"
End With
'Get the 5th paragraph
Set Rng = .Range.Paragraphs(5).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
Most grateful for any help