Könnte man vielleicht so machen:

Option Explicit

' Ermittelt alle Überschriften (Ebene 1-9) in diesem Word-Dokument,
' erstellt dann ein neues Dokument und fügt die Überschriften
' als Tabelle ein.
Public Sub Test()
  
  Dim colHeadings As VBA.Collection
  Dim iHeading As Long
  
  Set colHeadings = GetRangesOfHeadings(ThisDocument)
  If colHeadings.Count = 0 Then
    Call MsgBox("Es wurden keine Überschriften gefunden.", vbInformation)
    Exit Sub
  End If
  
  With Documents.Add()
    With .Tables.Add(.Content, colHeadings.Count, 1)
      For iHeading = 1 To colHeadings.Count
        .Cell(iHeading, 1).Range.Text = colHeadings(iHeading)
      Next
    End With
  End With
  
  Call MsgBox("Tabelle mit Überschriften wurde in einem neuen Word-Dokument erstellt.", vbInformation)
  
  Set colHeadings = Nothing
  
End Sub

' liefert eine Collection mit jenen Bereichen, in denen eine Überschrift (Ebene 1-9) steht
Private Function GetRangesOfHeadings(Document As Word.Document) As VBA.Collection
  
  Dim colHeadings As VBA.Collection
  Dim rngHeading As Word.Range
  Dim iHeading As Long
  
  Set colHeadings = New VBA.Collection
  
  For iHeading = wdStyleHeading1 To wdStyleHeading9 Step -1
    With Document.Content
      .Find.Style = iHeading
      Call .Find.Execute
      Do While .Find.Found
        Set rngHeading = ThisDocument.Range(.Start, .End)
        Call rngHeading.MoveEndWhile(vbCrLf, wdBackward)
        Call AddToCollectionSorted(colHeadings, rngHeading)
        Call .Find.Execute
      Loop
    End With
  Next
  
  Set GetRangesOfHeadings = colHeadings
  Set colHeadings = Nothing
  
End Function

' sortiert den Bereich von Überschriften, anhand der Position im Dokument, in die Collection ein
Private Sub AddToCollectionSorted(Collection As VBA.Collection, Range As Word.Range, Optional ByVal Start, Optional ByVal End_)
  
  If Collection.Count = 0 Then
    Call Collection.Add(Range)
    Exit Sub
  ElseIf Collection.Count = 1 Then
    If Range.Start >= Collection(1).Start Then
      Call Collection.Add(Range)
    Else
      Call Collection.Add(Range, Before:=1)
    End If
    Exit Sub
  End If
  
  If IsMissing(Start) Or CLng(Start) <= 0 Then Start = 1
  If IsMissing(End_) Or CLng(End_) > Collection.Count Then End_ = Collection.Count
  
  If End_ - Start = 0 Then
    If Range.Start >= Collection(Start).Start Then
      Call Collection.Add(Range, After:=Start)
    Else
      Call Collection.Add(Range, Before:=Start)
    End If
    Exit Sub
  End If
  
  Dim m As Long
  m = (Start + End_) \ 2
  
  If Range.Start >= Collection(m).Start Then
    Call AddToCollectionSorted(Collection, Range, m + 1, Collection.Count)
  Else
    Call AddToCollectionSorted(Collection, Range, 1, m - 1)
  End If
  
End Sub