Sub ParseFileByHeading() 
    Dim aDoc As Document 
    Dim bDoc As Document 
    Dim Rng As Range 
    Dim Rng1 As Range 
    Dim Rng2 As Range 
    Dim Counter As Long 
    Dim Ans$ 
    Call InsertAfterMethod 
    Ans$ = InputBox("Enter Filename", "Incremental number added") 
    If Ans$ <> "" Then 
        Set aDoc = ActiveDocument 
        Set Rng1 = aDoc.Range 
        Set Rng2 = Rng1.Duplicate 
        Do 
            With Rng1.Find 
                .ClearFormatting 
                .MatchWildcards = False 
                .Forward = True 
                .Format = True 
                .Style = "Heading 1" 
                .Execute 
            End With 
            If Rng1.Find.Found Then 
                Counter = Counter + 1 
                Rng2.Start = Rng1.End + 1 
                With Rng2.Find 
                    .ClearFormatting 
                    .MatchWildcards = False 
                    .Forward = True 
                    .Format = True 
                    .Style = "Heading 1" 
                    .Execute 
                End With 
                If Rng2.Find.Found Then 
                    Rng2.Select 
                    Rng2.Collapse wdCollapseEnd 
                    Rng2.MoveEnd wdParagraph, -1 
                    Set Rng = aDoc.Range(Rng1.Start, Rng2.End) 
                    Set bDoc = Documents.Add 
                    bDoc.Content.FormattedText = Rng 
                    bDoc.SaveAs Ans$ & Counter, wdFormatDocument 
                    bDoc.Close 
                Else 
                     'This collects from the last Heading 1
                     'to the end of the document.
                    If Rng2.End < aDoc.Range.End Then 
                        Set bDoc = Documents.Add 
                        Rng2.Collapse wdCollapseEnd 
                        Rng2.MoveEnd wdParagraph, -2 
                        Set Rng = aDoc.Range(Rng2.Start, aDoc.Range.End) 
                        bDoc.Content.FormattedText = Rng 
                        Call FindReplaceAlmostAnywhere 
                        bDoc.SaveAs Ans$ & Counter, wdFormatDocument 
                        bDoc.Close 
                    End If 
                End If 
            End If 
        Loop Until Not Rng1.Find.Found 
        Call FindReplaceAlmostAnywhere 
         'This is closing End If from Ans$
    End If 
End Sub 
Sub InsertAfterMethod() 
    Dim MyText As String 
    Dim MyRange As Object 
    Set MyRange = ActiveDocument.Range 
    MyText = "<Replace this with your text>" 
     ' Selection Example:
    Selection.EndKey Unit:=wdStory 
    Selection.InsertAfter (MyText) 
    Selection.Style = ActiveDocument.Styles("Heading 1") 
     ' Range Example:
     ' (Inserts text at the current position of the insertion point.)
     'MyRange.Collapse
     'MyRange.InsertAfter (MyText)
End Sub 
 
Public Sub FindReplaceAlmostAnywhere() 
    Dim rngStory As Word.Range 
    Dim lngJunk As Long 
    Dim MyText As String 
    MyText = "<Replace this with your text>" 
     'Fix the skipped blank Header/Footer problem as provided by Peter Hewett
    lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType 
     'Iterate through all story types in the current document
    For Each rngStory In ActiveDocument.StoryRanges 
         'Iterate through all linked stories
        Do 
            With rngStory.Find 
                .Text = "<Replace this with your text>" 
                .Replacement.Text = "" 
                .Wrap = wdFindContinue 
                .Execute Replace:=wdReplaceAll 
            End With 
             'Get next linked story (if any)
            Set rngStory = rngStory.NextStoryRange 
        Loop Until rngStory Is Nothing 
    Next 
End Sub