Word: Extracting headings and heading bookmarks

In the unlikely event that you may need to extract all heading references and numbered headings, here are two macros to do this:

Sub PrintBookmarksAndText()

    Dim doc As Document

    Set doc = ActiveDocument

    Set doctarget = Documents.Add

    Dim tbl As Table

    Dim newrow As Row

    Dim bm As Bookmark

    With doctarget

    Set tbl = .Tables.Add(Selection.Range, 1, 3)

      With tbl

          .Cell(1, 1).Range.Text = "Bookmark"

          .Cell(1, 2).Range.Text = "Heading Number"

          .Cell(1, 3).Range.Text = "Heading"

      End With

    End With

    For Each bm In doc.Bookmarks

        If bm.Range.Paragraphs(1).Style Like "Heading*" Then

          If Left(bm.Name, 4) = "_Ref" Then

            Debug.Print bm.Name & vbTab & bm.Range.Paragraphs(1).Range.ListFormat.ListString & vbTab & Left(bm.Range.Paragraphs(1).Range.Text, Len(bm.Range.Paragraphs(1).Range.Text) - 1)

            Set newrow = tbl.Rows.Add

            newrow.Cells(1).Range.Text = bm.Name

            newrow.Cells(2).Range.Text = bm.Range.Paragraphs(1).Range.ListFormat.ListString

            newrow.Cells(3).Range.Text = Left(bm.Range.Paragraphs(1).Range.Text, Len(bm.Range.Paragraphs(1).Range.Text) - 1)

          End If

        End If

    Next bm

End Sub

Sub PrintNumberedHeadings()

    Dim doc As Document

    Set doc = ActiveDocument

    Set doctarget = Documents.Add

    Dim tbl As Table

    Dim newrow As Row

    Dim bm As Bookmark

    Dim para As Paragraph

    With doctarget

    Set tbl = .Tables.Add(Selection.Range, 1, 2)

      With tbl

          .Cell(1, 1).Range.Text = "Heading Number"

          .Cell(1, 2).Range.Text = "Heading"

      End With

    End With

    For Each para In doc.Paragraphs

        If para.Style Like "Heading*" Then

            Debug.Print para.Range.ListFormat.ListString & vbTab & Left(para.Range.Text, Len(para.Range.Text) - 1)

            Set newrow = tbl.Rows.Add

            newrow.Cells(1).Range.Text = para.Range.ListFormat.ListString

            newrow.Cells(2).Range.Text = Left(para.Range.Text, Len(para.Range.Text) - 1)

        End If

    Next para

End Sub