SOLVED

How would I extract paragraph/list numbers and the paragraph text in VBA

Contributor

Hello,

I want like to have a VBA macro that will set a string for the paragraph/list number for every paragraph in the document along with a string for the text. For paragraphs that do not have a number then the first string should be empty.

 

For a document that might contain the following text:

1 This is a numbered heading

1.1 This is also a numbered heading

1.1.1 This is a paragraph that has a number on it

This is a paragraph that does not have a number on it

  1. This is a level 1 list entry

          (a) This is a level 2 list entry

 

I would be hoping to get the following

String 1

String 2

1

This is a numbered heading

1.1

This is also a numbered heading

1.1.1

This is a paragraph that has a number on it

 

This is a paragraph that does not have a number on it

1

This is a level 1 list entry

(a)

This is a level 2 list entry

 

I am fairly competent with VBA on Excel and Project but I have barely touched Word.

So, if someone could direct me to the appropriate Word objects and fields I would need I would appreciate it.

 

Thanks in advance

3 Replies
best response confirmed by Gilgamesh1964 (Contributor)
Solution

@Gilgamesh1964 

 

You should be able to use the ListString property to retrieve the number format for each level. See https://wordmvp.com/FAQs/Numbering/ListString.htm.

@Gilgamesh1964 Run a macro containing the following code when you have the document open

 

 

 

Dim docsource As Document, doctarget As Document
Dim i As Long
Dim tbl As Table
Dim newrow As Row
Set docsource = ActiveDocument
Set doctarget = Documents.Add
With doctarget
    Set tbl = .Tables.Add(Selection.Range, 1, 2)
    With tbl
        .Cell(1, 1).Range.Text = "String 1"
        .Cell(1, 2).Range.Text = "String 2"
    End With
End With
With docsource
    .ConvertNumbersToText
    For i = 1 To .Paragraphs.Count
        Set newrow = tbl.Rows.Add
        If Left(.Paragraphs(i).Style, 7) = "Heading" Then
            With newrow
                .Cells(1).Range.Text = Left(docsource.Paragraphs(i).Range.Text, InStr(docsource.Paragraphs(i).Range.Text, vbTab) - 1)
                .Cells(2).Range.Text = Mid(docsource.Paragraphs(i).Range.Text, InStr(docsource.Paragraphs(i).Range.Text, vbTab) + 1)
            End With
        Else
            newrow.Cells(2).Range.Text = .Paragraphs(i).Range.Text
        End If
    Next i
    .Close wdDoNotSaveChanges
End With
doctarget.Activate
Thank you both for replying.
I now have a solution that works for me.