Sub ExtractUserStories()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Tbl As Table, Rng As Range
Dim ArrRls, i As Long, r As Long, bExp As Boolean
ArrRls = Array("Profit Analyzer", "Deal Manager", "Price Manager")
Set DocSrc = ActiveDocument
For i = 0 To UBound(ArrRls)
  Documents.Add (DocSrc.AttachedTemplate.FullName)
  ActiveDocument.SaveAs2 FileName:=DocSrc.Path & "\" & ArrRls(i) & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
Next
With DocSrc.Range
  .ListFormat.ConvertNumbersToText
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Style = wdStyleHeading1
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  Do While .Find.Found
    Set Rng = .Paragraphs(1).Range
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    For i = 0 To UBound(ArrRls)
      For Each Tbl In Rng.Tables
        bExp = False
        With Tbl
          If InStr(.Range.Text, ArrRls(i)) > 0 Then
            Set DocTgt = Documents(ArrRls(i) & ".docx"): bExp = True
            With DocTgt
              With .Range
                .Characters.Last.FormattedText = Rng.FormattedText
                .InsertAfter Chr(12)
              End With
              .Save
              DoEvents
            End With
            Exit For
          End If
        End With
      Next
    Next
    .Start = Rng.End
    .Find.Execute
  Loop
End With
For i = 0 To UBound(ArrRls)
  Documents(ArrRls(i) & ".docx").Close True
Next
DocSrc.Undo (1)
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub