VB - UNMERGE WORD DOCUMENTS SAVING FILENAME

[stevembe]

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

[stevembe]

Sorry meant to show the solution I tried but it is highlighting the .Range where I am trying to get the 15th paragraph and coming back with Compile Error. Method or data member not found:


'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
'Get the 12th paragraph
Set Rng = .Range.Paragraphs(12).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct balance of file name
StrTxt = StrTxt & .Text & ".docx"
End With

[gmayor]

In theory the following will work. I say 'theory' because there is no check to determine that the two paragraphs contain the information required nor that the paragraphs contain valid filename characters nor that the combination produces a valid path length.

Dim Rng As Range
Dim strTxt As String: strTxt = "C:\Final\"
'Get the 14th paragraph
Set Rng = ActiveDocument.Range.Paragraphs(14).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & "_"
Set Rng = ActiveDocument.Range.Paragraphs(12).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & ".docx"
MsgBox strTxt

[stevembe]

In theory the following will work. I say 'theory' because there is no check to determine that the two paragraphs contain the information required nor that the paragraphs contain valid filename characters nor that the combination produces a valid path length.

Dim Rng As Range
Dim strTxt As String: strTxt = "C:\Final\"
'Get the 14th paragraph
Set Rng = ActiveDocument.Range.Paragraphs(14).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & "_"
Set Rng = ActiveDocument.Range.Paragraphs(12).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & ".docx"
MsgBox strTxt

Thanks so much for your suggestion but I am actually trying to adapt it to get the 14th, 13th and 12th paragraph but your suggestion only mentions the 14th and 12th.

[gmayor]

It is no more difficult to get three paragraphs as two

Dim Rng As Range
Dim strTxt As String: strTxt = "C:\Final\"

'Get Para 14
Set Rng = ActiveDocument.Range.Paragraphs(14).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & "_"

'Get Para 13
Set Rng = ActiveDocument.Range.Paragraphs(13).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & "_"

'Get Para 12
Set Rng = ActiveDocument.Range.Paragraphs(12).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & ".docx"

MsgBox strTxt

[stevembe]

Again thank you but as you can probably tell my VB is not too great at all. I am confused that you extract the paragraphs after specifying the file path so I am not sure what to replace in my original code and where to put what you kindly put together.

[stevembe]

I seem to be getting close in that I have adjusted this so that includes the three paragraphs I want. The macro runs, no error messages but it only picks up paragraphs 14 and 15 but not 13. Can anybody see where the following extract is going wrong:


'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
End With
'Get the 15th paragraph
Set Rng = .Range.Paragraphs(15).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct balance of file name

[gmayor]

I annotated the code to make it easy for you? In your original macro, replace your section

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

with


With .Sections(i)
strTxt = "C:\Final\"
'Get Para 14
Set Rng = .Range.Paragraphs(14).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & "_"

'Get Para 13
Set Rng = .Range.Paragraphs(13).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & "_"

'Get Para 12
Set Rng = .Range.Paragraphs(12).Range
Rng.End = Rng.End - 1
strTxt = strTxt & Rng.Text & ".docx"

Set Rng = .Range
Rng.End = Rng.End - 1
Rng.Copy

End With

[stevembe]

Graham, thank you so much for your help, it is now working perfectly. I can't thank you enough for your time and help, it is very much appreciated.