Sub ExtractListsWithHeadings()
    Dim srcDoc As Document
    Dim destDoc As Document
    Dim para As Paragraph
    Dim inList As Boolean
    Dim listRange As Range
    Dim tbl As Table
    Dim aRngHead As Range
    Dim headingText As String
    
    Set srcDoc = ActiveDocument
    Set destDoc = Documents.Add
    
    ' Create a table in the new document
    Set tbl = destDoc.Tables.Add(destDoc.Range, 1, 2)
    tbl.Cell(1, 1).Range.Text = "Section Number"
    tbl.Cell(1, 2).Range.Text = "List Contents"
    
    inList = False
    
    For Each para In srcDoc.Paragraphs
        If para.Style.NameLocal Like "Heading*" Then
            ' Capture the heading as the last seen heading
            Set aRngHead = para.Range
            headingText = aRngHead.ListFormat.listString & vbTab & aRngHead.Text
            ' Remove any trailing new line characters
            headingText = Trim(headingText)
        End If
        
        If Not para.Range.ListFormat.List Is Nothing Then
            ' Check if we've just started a new list
            If Not inList Then
                Set listRange = para.Range
                inList = True
            Else
                ' Extend the range to include the current list item
                listRange.End = para.Range.End
            End If
        ElseIf inList Then
            ' If we were in a list and now we're not, handle the list
            tbl.Rows.Add
            tbl.Cell(tbl.Rows.Count, 1).Range.Text = headingText
            listRange.Copy
            tbl.Cell(tbl.Rows.Count, 2).Range.PasteAndFormat (wdFormatOriginalFormatting)
            inList = False
        End If
    Next para
    
    ' Check if the last paragraph of the document was part of a list
    If inList Then
        tbl.Rows.Add
        tbl.Cell(tbl.Rows.Count, 1).Range.Text = headingText
        listRange.Copy
        tbl.Cell(tbl.Rows.Count, 2).Range.PasteAndFormat (wdFormatOriginalFormatting)
    End If
End Sub