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(wdFormatOriginalForma tting)
Next
For Each HdFt In Rng.Sections(1).Footers
HdFt.Range.Copy
.Sections(1).Footers(HdFt.Index).Range.PasteAndFormat(wdFormatOriginalForma tting)
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.