Разделить документ и сохранить с именем из фрагмента текста

Sub AWordCounter()
Dim dThatDoc As Document
Dim dNewDoc As Document
Dim sFullName, sName As String
sFullName = Word.Application.ActiveDocument.FullName
sName = Word.Application.ActiveDocument.Name
Set dThatDoc = Word.Application.ActiveDocument
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^m"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True
        Do While .Execute = True
            Selection.Range.Delete
            Selection.TypeBackspace
            dThatDoc.Range(0, Selection.End).Cut
            Set dNewDoc = Word.Application.Documents.Add(Visible:=False)
            dNewDoc.Activate
            Selection.Paste
            'Тут надо применить тот макрос, что содержится в приложенной ниже теме
            dThatDoc.Activate
        Loop
'Если после последнего куска текста нет разрыва страницы, то надо раскомментить код ниже
    dThatDoc.Range(0, dThatDoc.Characters.Count).Cut
    Set dNewDoc = Word.Application.Documents.Add(Visible:=False)
            dNewDoc.Activate
            Selection.Paste
    'Снова код сохраняющий документ с именем = первойстроке
    dThatDoc.Activate
End Sub