#1
|
|||
|
|||
Pull all lists from document
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. Code:
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 |
#2
|
||||
|
||||
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. Code:
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
"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 Code:
With aRng.Find .ClearFormatting .Replacement.ClearFormatting .Text = "" .Forward = True Do While .Execute aRng.Start = aRng.Paragraphs(1).Range.Start Code:
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 |
#4
|
||||
|
||||
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" }
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#5
|
|||
|
|||
Solved
Code:
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 |
#6
|
|||
|
|||
errr not fully done, it does not pull the heading level name correctly. here is the fixed one.
Code:
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 |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
VBA script to pull data into existing document | Formd | Word VBA | 4 | 05-11-2021 03:47 AM |
Multiple Multi-Level Lists in Same Document | TimGS | Word | 6 | 05-15-2018 05:29 AM |
Multilevel lists - Document starting with second level | thara | Word | 2 | 05-02-2016 02:37 AM |
How to have two different numbering lists in a document? | saseymour | Word | 3 | 09-29-2014 11:30 AM |
Several Multilevel Lists in a document | Aston | Word | 4 | 10-07-2012 01:50 AM |