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.