Sub ExtractAllLists()
    Dim aRng As Range
    Dim aRngHeader As Range
    Dim aDoc As Document
    Dim aDocNew As Document
    Dim aTbl As Table
    Dim aRow As Row
    Dim sNum As String

    Set aDoc = ActiveDocument
    Set aRng = aDoc.Range
    Set aDocNew = Documents.Add
    Set aTbl = aDocNew.Tables.Add(aDocNew.Range, 1, 3)
    aTbl.Cell(1, 1).Range.Text = "List Type"
    aTbl.Cell(1, 2).Range.Text = "List Contents"
    aTbl.Cell(1, 3).Range.Text = "Heading"

    With aRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ""
        .Forward = True
        Do While .Execute
            aRng.Start = aRng.Paragraphs(1).Range.Start
            Set aRow = aTbl.Rows.Add
            If aRng.ListFormat.ListType <> wdListNoNumbering Then  
                aRow.Cells(2).Range.FormattedText = aRng.FormattedText
            Else
                aRow.Cells(2).Range.Text = aRng.Text
            End If
                ' stuck here




    ' Retrieve heading information
    Set aRngHead = aRng.GoToPrevious(wdGoToHeading)
    aRngHead.End = aRngHead.Paragraphs(1).Range.End - 1
    aRow.Cells(3).Range.Text = aRngHead.ListFormat.listString & vbTab & aRngHead.Text
    
    ' Move to the end of the range
    aRng.Collapse Direction:=wdCollapseEnd
    aRng.End = aDoc.Range.End