Option Explicit 
 
Sub SeperateHeadings() 
     
    Dim TotalLines      As Long 
    Dim x               As Long 
    Dim Groups()        As Long 
    Dim Counter         As Long 
    Dim y               As Long 
    Dim FilePath        As String 
    Dim FileName()      As String 
     
    FilePath = ActiveDocument.Path 
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1 
    Do 
        TotalLines = Selection.Range.Information(wdFirstCharacterLineNumber) 
        Selection.MoveDown Unit:=wdLine, Count:=1 
    Loop While TotalLines <> Selection.Range.Information(wdFirstCharacterLineNumber) 
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1 
    For x = 1 To TotalLines 
        If Selection.Style = "Heading 1" Then 
            Counter = Counter + 1 
            ReDim Preserve Groups(1 To Counter) 
            ReDim Preserve FileName(1 To Counter) 
            Groups(Counter) = x 
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend 
            FileName(Counter) = Selection.Text 
            FileName(Counter) = Left(Selection.Text, Len(FileName(Counter)) - 1) 
            Selection.HomeKey Unit:=wdLine, Extend:=wdExtend 
        End If 
        Selection.MoveDown Unit:=wdLine, Count:=1 
    Next 
    Counter = Counter + 1 
    ReDim Preserve Groups(1 To Counter) 
    Groups(Counter) = TotalLines 
     
    For x = 1 To UBound(Groups) - 1 
        y = Groups(x + 1) - Groups(x) 
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=Groups(x) 
        Selection.MoveDown Unit:=wdLine, Count:=y, Extend:=wdExtend 
        Selection.Copy 
        Documents.Add 
        Selection.Paste 
        ActiveDocument.SaveAs FilePath & "\" & FileName(x) & ".doc" 
        ActiveDocument.Close 
    Next x 
     
End Sub