Separating Sections into separate word document

After a bit of manual editing to apply the Heading 1 style to all of the song titles and removing multiple consecutive instances of that style in a number of places and using the replace facility and number of times to remove other irregularities and then finally using it to replace Heading 1 style paragraphs by  ^m^& in the replace control to get the document to the point where each song started on a new page , I then used the following macro to create separate files for each song, named with the title of the song

Dim Counter As Long, Source As Document, Target As Document

Set Source = ActiveDocument

Dim Pages As Long

Dim rngDocName As Range

Dim strDocName As String, strFolder As String

Dim fd As FileDialog

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

With fd

    .Title = "Select the folder into which the documents will be saved."

    If .Show = -1 Then

        strFolder = .SelectedItems(1) & "\"

    Else

        MsgBox "The documents will be saved in the default document file location."

        strFolder = ""

    End If

End With

Selection.HomeKey Unit:=wdStory

Pages = Source.BuiltInDocumentProperties(wdPropertyPages)

While Counter < Pages

    Counter = Counter + 1

    Source.Bookmarks("\Page").Range.Cut

    Set Target = Documents.Add

    Target.Range.Paste

    Set rngDocName = Target.Range.Paragraphs(1).Range

    rngDocName.End = rngDocName.End - 1

    strDocName = Replace(rngDocName.Text, ",", "")

    strDocName = Replace(strDocName, "'", "")

    strDocName = Replace(strDocName, ":", "")

    Target.SaveAs FileName:=strFolder & strDocName

    Target.Close

Wend