Option Explicit
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
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
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