SPLIT MERGE SINGLE FILES NAMING FILEPATH TO SAVE FROM HEADER

[stevembe]

Firstly thanks for reading.

Courtesy of this forum I have some excellent VBA that automatically splits a merged word document into single files, it names them automatically by getting the data from the paragraph number and saves them to a defined file path. It has been invaluable to me but now I have another similar query. I need to do exactly the same but for the merged document I have I need it to do exactly the same but on this document save the file name by using three words contained in the header which look like this:

24680 John Smith A-BB-CC-DD

Most grateful for any assistance.

[stevembe]

Sorry, might have been useful if I had included the VBA that I am currently using. Is it possible to adapt this so I can name the files once split as above?

Sub Demo()
    Application.ScreenUpdating = False
    Dim i As Long, StrTxt As String, Rng AsRange, Doc As Document, HdFt As HeaderFooter
    With ActiveDocument
         'Processeach Section
        For i = 1 To.Sections.Count - 1
    With .Sections(i)
    StrTxt ="J:\SD\HR\HR\Systems\Steve\"
     'Get Para 10
    Set Rng = .Range.Paragraphs(10).Range
    Rng.End = Rng.End - 1
    StrTxt = StrTxt & Rng.Text &"_"

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

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

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

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 & closethe 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

[stevembe]

I have no idea where that FONT SIZE COLOUR came from???? I only entered the code.