I still don't know what you are trying to do, because listype 2 is a bulleted list, not a numbered heading:
Private Sub cmdExtractShalls_Click()
Dim oApp As Object
Dim oSheet As Object
Dim oRng As Range, oRngHeader As Range
Dim lngRowCount As Long
Dim lngParCount As Long
Dim oRngBounds As Range
Dim lngPage As Long
If oSheet Is Nothing Then
Set oApp = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xlsx
Set oSheet = oApp.workbooks.Open("D:\Test.xlsx").Sheets("Sheet1")
lngRowCount = 1
With oSheet
.Cells(lngRowCount, 1) = "Page Number"
.Cells(lngRowCount, 2) = "Section Number"
.Cells(lngRowCount, 3) = "Sentence Text"
End With
lngRowCount = lngRowCount + 1
End If
For lngParCount = 1 To ActiveDocument.Paragraphs.Count
Set oRng = ActiveDocument.Paragraphs(lngParCount).Range
Set oRngBounds = oRng.Duplicate
With oRng.Find
Do
.Text = "shall" ' the word I am looking for
.Execute
If .Found And oRng.InRange(oRngBounds) Then
lngPage = oRng.Information(wdActiveEndPageNumber)
oRng.Expand Unit:=wdSentence
oRng.Copy
oRng.Collapse wdCollapseEnd
oSheet.Cells(lngRowCount, 1) = lngPage
oSheet.Cells(lngRowCount, 3).Select
oSheet.Paste
Set oRngHeader = oRng.Duplicate
Do Until oRngHeader.Paragraphs(1).Range.ListFormat.ListType = 3 Or oRngHeader.Paragraphs(1).Range.ListFormat.ListType = 4
oRngHeader.Move wdParagraph, -1
If oRngHeader.Paragraphs(1).Range = ActiveDocument.Paragraphs(1).Range Then Exit Do
Loop
oSheet.Cells(lngRowCount, 2) = oRngHeader.ListParagraphs(1).Range.ListFormat.ListString
lngRowCount = lngRowCount + 1
End If
Loop While .Found
End With
Next lngParCount
If Not oSheet Is Nothing Then
oSheet.usedrange.Columns.AutoFit
oApp.workbooks(1).Close True
oApp.Quit
Set oSheet = Nothing
Set oApp = Nothing
End If
Set oRng = Nothing
End Sub
Sub Test()
MsgBox Selection.Paragraphs(1).Range.ListParagraphs(1).Range.ListFormat.ListType
End Sub