Updated Code Still Not Working :(

[HKK]

Here is all the code I am using...Still now working for Save As

Sub SaveRecsAsFiles()
' Convert all sections to Subdocs
AllSectionsToSubDoc ActiveDocument
'Save each Subdoc as a separate file
SaveAllSubDocs ActiveDocument
End Sub

Sub AllSectionsToSubDoc(ByRef doc As Word.Document)
Dim secCounter As Long
Dim NrSecs As Long
NrSecs = doc.Sections.Count
'Start from the end because creating
'Subdocs inserts additional sections
For secCounter = NrSecs - 1 To 1 Step -1
doc.Subdocuments.AddFromRange _
doc.Sections(secCounter).Range
Next secCounter
End Sub

Sub SaveAllSubDocs(ByRef doc As Word.Document)
Dim subdoc As Word.Subdocument
Dim newdoc As Word.Document
Dim docCounter As Long
docCounter = 1
'Must be in MasterView to work with
'Subdocs as separate files
doc.ActiveWindow.View = wdMasterView
For Each subdoc In doc.Subdocuments
Set newdoc = subdoc.Open
'Remove NextPage section breaks
'originating from mailmerge
RemoveAllSectionBreaks newdoc
With newdoc
With Dialogs(wdDialogFileSaveAs)
.Name = ActiveDocument.BuiltInDocumentProperties("Title")
.Show
..Close
End With
docCounter = docCounter + 1
Next subdoc
End Sub
Sub RemoveAllSectionBreaks(doc As Word.Document)
With doc.Range.Find
..ClearFormatting
..Text = "^b"
With .Replacement
..ClearFormatting
..Text = ""
End With
..Execute Replace:=wdReplaceAll
End With
End Sub