Pull all lists from document

[tonykekw]

VBA for MS Word
trying to extract all lists with their respected data.
a) list type
b) list Content


c) heading level

this data gets added to a new word doc for the time being.
I am getting stuck on how to go about pulling the lists. ( I use the bult in MS Word list types). Eventually I would like to pull the data and move it to an excel sheet.

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

practicing VBA everyday, if anyone has suggestions on learning VBA let me know, i dont want to ask to many Q. or spam help. thanks

[Guessed]

Lets take a step back and think about this a little.

First, if you also want to grab headings which are numbered then they are ALSO going to be list items so you don't need a specific column for that information.

Second, if you run a find for nothing, what exactly do you think it will find?

So we need to consider alternate ways to achieve your aims and I'll start by asking what is the point of this activity? What is a collection of the list items in Excel going to do for you?

From a coding point of view, I thought a better way to iterate through the list items would be the following approach. Unfortunately, this does indeed return each list item but it iterates through the paragraphs in the order the lists were applied rather than the order that the paragraphs appear in the document. Perhaps if we included a paragraph index as an extra column you could simply sort on that to put the paragraphs in order.

  Dim aLP As Paragraph, aDoc As Document
  Set aDoc = ActiveDocument
  Debug.Print aDoc.ListParagraphs.Count
  For Each aLP In aDoc.ListParagraphs
    aLP.Range.Select
    With aLP.Range.ListFormat
      Debug.Print .ListType, .ListString, aLP.Range.Text
    End With
  Next aLP

[tonykekw]

"I'll start by asking what is the point of this activity? What is a collection of the list items in Excel going to do for you?"

The point of the activity is to find and organize a bunch of rules that are scattered across the document. Over the span of multiple documents. Having the data on excel was a suggestion. It is not a requirement. To me having the data on a sheet would feel more organized.

It doesn't matter if the data pulled is not by how the paragraphs appear in the document. Pulling the lists themselves would be enough. I am trying to essentially rebuild to pull and rebuild the documents.

Adding an Index is a great idea, having new ideas helps a lot.

I am assuming I would drop the

With aRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ""
        .Forward = True
        Do While .Execute
            aRng.Start = aRng.Paragraphs(1).Range.Start

Something like this:

Sub PrintListParagraphsInfo()
    Dim aLP As Paragraph
    Dim aDoc As Document
    Set aDoc = ActiveDocument
    Debug.Print "Total List Paragraphs: " & aDoc.ListParagraphs.Count
    For Each aLP In aDoc.ListParagraphs
        aLP.Range.Select
        With aLP.Range.ListFormat
            Debug.Print "List Type: " & .ListType
            Debug.Print "List String: " & .ListString
            Debug.Print "Text: " & aLP.Range.Text
        End With
    Next aLP
End Sub

[Guessed]

Rather than only considering a VBA-only solution, IF you've been a good Word user, your document would be making consistent use of styles which would allow you to simply include a TOC which collects all your lists via those styles
For example, a TOC field like this might gather most lists in your doc
{TOC \o "1-6" \t "List Number,7,List Multi,7,List Multi 2,8,List Paragraph,7" }

[tonykekw]

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

got it, thanks

[tonykekw]

errr not fully done, it does not pull the heading level name correctly. here is the fixed one.

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 = "Heading Level & Text"
    tbl.Cell(1, 2).Range.Text = "List Contents"
    
    inList = False
    
    For Each para In srcDoc.Paragraphs
        If Not para.Range.ListFormat.List Is Nothing Then
            If Not inList Then
                ' Start of a new list
                Set listRange = para.Range
                inList = True
                
                ' Navigate to the nearest heading for the current list
                Set aRngHead = para.Range.GoToPrevious(wdGoToHeading)
                If Not aRngHead Is Nothing Then
                    ' Adjust the range to exclude the paragraph mark
                    aRngHead.End = aRngHead.Paragraphs(1).Range.End - 1
                    ' Combine list formatting (if any) with the heading text
                    headingText = aRngHead.ListFormat.listString & vbTab & aRngHead.Text
                    ' Trim to remove any trailing newline characters
                    headingText = Trim(headingText)
                Else
                    headingText = "No Heading"
                End If
            Else
                ' Extend the range to include the current list item
                listRange.End = para.Range.End
            End If
        ElseIf inList Then
            ' End of a list, so handle it
            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 ' Reset for the next list
        End If
    Next para
    
    ' Handle case where the document ends with 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