Saving a file name as certain founds on a specified line

[Articade]

Hello. (using word and excel 2010) I am working off of microsoft word and
right now, my code is used to:

1) Separate mail merged pages, remove the section breaks, and set default
values (font, paragraph spacing).

2) Save each Separate page as a separate file. (only saves as numbers).

What I am trying to do is fix the saving part. I want to make it so the
macro finds the line with the word "To:", and save the file name as
different words on that line, for example, the line would be:

To: Mr Jacob A Compton

I would want to save the file name as Mr Jacob Jacob A Compton.

How do I get this to work? Thank you for your help.


Option Explicit

Sub DeleSectionBreaks()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^b"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub DefaultSettings()
Selection.WholeStory
Selection.Font.Name = "Courier New"
Selection.Font.Size = 12
With Selection.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.LineUnitBefore = 0
.LineUnitAfter = 0
.WordWrap = True
End With
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(1.2)
.BottomMargin = InchesToPoints(0.5)
.LeftMargin = InchesToPoints(1)
.RightMargin = InchesToPoints(1)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
.LayoutMode = wdLayoutModeDefault
End With
End Sub

Sub AllSectionsToSubDoc()

Dim x As Long
Dim Sections As Long
Dim Doc As Document

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set Doc = ActiveDocument
Sections = Doc.Sections.Count
For x = Sections - 1 To 1 Step -1
Doc.Sections(x).Range.Copy
Documents.Add
ActiveDocument.Range.Paste
Call DeleSectionBreaks
Call DefaultSettings
ActiveDocument.SaveAs (Doc.Path & "\" & x & ".doc")
ActiveDocument.Close False


Next x

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub