stevembe
05-09-2016, 07:06 AM
I have the following code which is perfect for use in the past but now I need to add to it so that it now gets the 12th paragraph in the filename. I have tried all kinds but just can't get it to work. Really grateful if anybody could help me out:
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:\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
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:\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