Sub CompileInstructions()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Rng As Range, r As Long
Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add
With DocTgt
  .Tables.Add .Range, Numrows:=1, NumColumns:=2
End With
With DocSrc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Format = True
    .Style = "Instructions"
    .Wrap = wdFindStop
    .Execute
  End With
  Do While .Find.Found
    Set Rng = .Paragraphs(1).Range
    With DocTgt.Tables(1)
      .Rows.Add
      r = .Rows.Count
      With .Cell(r, 2).Range
        .FormattedText = Rng.FormattedText
        .Characters.Last.Previous.Delete
      End With
    End With
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    With DocTgt.Tables(1)
      With .Cell(r, 1).Range
        .FormattedText = Rng.Paragraphs.First.Range.FormattedText
        'or, if the output doesn't include all headings from the source
        '.Text = Rng.Paragraphs.First.Range.ListFormat.ListString & vbTab & Rng.Paragraphs.First.Range.Text
        .Characters.Last.Previous.Delete
      End With
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
With DocTgt.Tables(1)
  .Cell(1, 1).Range.Text = "Section"
  .Cell(1, 2).Range.Text = "Instructions"
  .Rows(1).HeadingFormat = True
  .Rows(1).Range.Style = "Strong"
End With
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub