Extracting "Shall" Statements with Associated Paragraph Number

[sooonergurli]

I found a helpful script on this site that was created by lucas. It extracts shall statements from a word doc and places them in an .xlsx spreadsheet. I would also like for the script to pull the associated paragraph number with the "shall" statement and place all of that in the xlsx spreadsheet...paragraph number in first column and shall statement in the next column.

I am a complete novice, so I have no idea how to make that happen.

Here is the script by lucas:

' Put this code in a module:

Option Explicit

Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
intRowCount = 1
Set aRange = ActiveDocument.Range
With aRange.Find
Do
.Text = "shall" ' the word I am looking for
.Execute
If .Found Then
aRange.Expand Unit:=wdSentence
aRange.Copy
aRange.Collapse wdCollapseEnd
If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xlsx
Set objSheet = appExcel.workbooks.Open("C:\temp\test.xlsx").Sheets("Sheet1")
intRowCount = 1
End If
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + 1
End If
Loop While .Found
End With
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub

[gmayor]

If you want a related paragraph count you are going to have to process the paragraphs separately and count them e.g. as follows. Inevitably this will take longer to process.

Option Explicit

Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
Dim intParaCount As Integer

    If objSheet Is Nothing Then
        Set appExcel = CreateObject("Excel.Application")
        'Change the file path to match the location of your test.xlsx
        Set objSheet = appExcel.workbooks.Open("C:\Test\test.xlsx").Sheets("Sheet1")
        intRowCount = 1
        objSheet.Cells(intRowCount, 1) = "Paragraph Number"
        objSheet.Cells(intRowCount, 2) = "Sentence Text"
        intRowCount = intRowCount + 1
    End If
    
    For intParaCount = 1 To ActiveDocument.Paragraphs.Count
        Set aRange = ActiveDocument.Paragraphs(intParaCount).Range
        With aRange.Find
            Do
                .Text = "shall"    ' the word I am looking for
                .Execute
                If .Found Then
                    aRange.Expand Unit:=wdSentence
                    aRange.Copy
                    aRange.Collapse wdCollapseEnd
                    objSheet.Cells(intRowCount, 1) = intParaCount
                    objSheet.Cells(intRowCount, 2).Select
                    objSheet.Paste
                    intRowCount = intRowCount + 1
                End If
            Loop While .Found
        End With
    Next intParaCount
    If Not objSheet Is Nothing Then
        objSheet.usedrange.Columns.AutoFit
        appExcel.workbooks(1).Close True
        appExcel.Quit
        Set objSheet = Nothing
        Set appExcel = Nothing
    End If
    Set aRange = Nothing
End Sub

[sooonergurli]

Thank you gmayor!

I ran the script and I received the following error after it ran for about an hour: Run-time error '6': Overflow

It stopped right after objSheet.Paste. The row below that intRowCount = intRowCount + 1 is highlighted in yellow for debug.

As I said, I no nothing about this, so I have no idea how to debug it or what caused the error.

[gmaxey]

Try:

Sub FindWordCopySentence()
    Dim appExcel As Object
    Dim objSheet As Object
    Dim aRange As Range
    Dim intRowCount As Integer
    Dim intParaCount As Integer
    Dim oRngBounds As Range
    If objSheet Is Nothing Then
        Set appExcel = CreateObject("Excel.Application")
         'Change the file path to match the location of your test.xlsx
        Set objSheet = appExcel.workbooks.Open("C:\Test\test.xlsx").Sheets("Sheet1")
        intRowCount = 1
        objSheet.Cells(intRowCount, 1) = "Paragraph Number"
        objSheet.Cells(intRowCount, 2) = "Sentence Text"
        intRowCount = intRowCount + 1
    End If
     
    For intParaCount = 1 To ActiveDocument.Paragraphs.Count
        Set aRange = ActiveDocument.Paragraphs(intParaCount).Range
        Set oRngBounds = aRange.Duplicate
        With aRange.Find
            Do
                .Text = "shall" ' the word I am looking for
                .Execute
                If .Found And aRange.InRange(oRngBounds) Then
                    aRange.Expand Unit:=wdSentence
                    aRange.Copy
                    Debug.Print aRange
                    aRange.Collapse wdCollapseEnd
                    
                    objSheet.Cells(intRowCount, 1) = intParaCount
                    objSheet.Cells(intRowCount, 2).Select
                    objSheet.Paste
                    intRowCount = intRowCount + 1
                End If
            Loop While .Found
        End With
    Next intParaCount
    If Not objSheet Is Nothing Then
        objSheet.usedrange.Columns.AutoFit
        appExcel.workbooks(1).Close True
        appExcel.Quit
        Set objSheet = Nothing
        Set appExcel = Nothing
    End If
    Set aRange = Nothing
End Sub

[Paul_Hossler]

I'd change to Long's if you're getting an overflow just to be sure

Dim intRowCount As Long 
 Dim intParaCount As Long

[gmaxey]

Paul,

Good point. I don't know how large the OP's document is, but running an hour seemed excessive in any case and I have assumed the issue could be caused by a run-a-way range.

[dbowlds]

Hello, I know this is an old post (which, I think should have been flagged as solved because the solution provided works great!). I am wondering how the output could cite the page number in addition to or instead of paragraphs? Any ideas? For long documents, the page number would be more useful.

[gmaxey]

Something like this:

Sub FindWordCopySentence()
    Dim appExcel As Object
    Dim objSheet As Object
    Dim aRange As Range
    Dim intRowCount As Integer
    Dim intParaCount As Integer
    Dim oRngBounds As Range
    If objSheet Is Nothing Then
    Dim lngPage As Long
        Set appExcel = CreateObject("Excel.Application")
         'Change the file path to match the location of your test.xlsx
        Set objSheet = appExcel.workbooks.Open("D:\test.xlsx").Sheets("Sheet1")
        intRowCount = 1
        objSheet.Cells(intRowCount, 1) = "Paragraph Number"
        objSheet.Cells(intRowCount, 2) = "Sentence Text"
        intRowCount = intRowCount + 1
    End If
     
    For intParaCount = 1 To ActiveDocument.Paragraphs.Count
        Set aRange = ActiveDocument.Paragraphs(intParaCount).Range
        Set oRngBounds = aRange.Duplicate
        With aRange.Find
            Do
                .Text = "shall" ' the word I am looking for
                .Execute
                If .Found And aRange.InRange(oRngBounds) Then
                    lngPage = aRange.Information(wdActiveEndPageNumber)
                    aRange.Expand Unit:=wdSentence
                    aRange.Copy
                    Debug.Print aRange
                    aRange.Collapse wdCollapseEnd
                    
                    objSheet.Cells(intRowCount, 1) = intParaCount & " - Page: " & lngPage
                    objSheet.Cells(intRowCount, 2).Select
                    objSheet.Paste
                    intRowCount = intRowCount + 1
                End If
            Loop While .Found
        End With
    Next intParaCount
    If Not objSheet Is Nothing Then
        objSheet.usedrange.Columns.AutoFit
        appExcel.workbooks(1).Close True
        appExcel.Quit
        Set objSheet = Nothing
        Set appExcel = Nothing
    End If
    Set aRange = Nothing
End Sub

[dbowlds]

Greg! This works perfectly! Thank you so very much for revisiting this old post for me. I greatly appreciate it. What is especially valuable to me is that I can see what changes you made to the original post, giving me a chance to learn a little. Thank you!
Since I did not post this originally, proper protocol would be that I should NOT flag this as solved, right? (I am still learning how the forum works.)

[gmaxey]

I'm not a moderator (or if I am then I've forgotten about it). I think that as the code as published worked and then it works as modified for you then marking the thread solved (if you even have that option) wouldn't be a capital offense.

[dbowlds]

Thanks, I just tried and it doesn't give me that option, so it must be set up to only allow the person who started the thread (or is a moderator) mark it as solved. Thanks for all your help. This is perfect for my needs!

[dbowlds]

Greg, it's me again. I am hoping I can impose upon your goodwill one more time...
I took some code from another one of your excellent posts on this form - it won't let me post the full URL for some reason but the subject is "getting-the-paragraph-heading-of-current-location&highlight=find+heading+for+text)." I tried to incorporate it into the above code to try to add a 3rd column to the extracted spreadsheet, this one including the header under which the shall statement has been found.

Here is my feeble attempt at this (obviously I do not understand the range function). When I run this it locks up Word. I think it's looping endlessly but do not know how to fix it. I think I have caused overlapping ranges or something like that.

Private Sub cmdExtractShalls_Click()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As range
Dim intRowCount As Integer
Dim intParaCount As Integer
Dim oRngBounds As range

Dim oRng As range

If objSheet Is Nothing Then

Dim lngPage As Long
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xlsx
Set objSheet = appExcel.workbooks.Open("C:\test\test.xlsx").Sheets("Sheet1")
intRowCount = 1
objSheet.Cells(intRowCount, 1) = "Page Number"
objSheet.Cells(intRowCount, 2) = "Section Number"
objSheet.Cells(intRowCount, 3) = "Sentence Text"
intRowCount = intRowCount + 1
End If

For intParaCount = 1 To ActiveDocument.Paragraphs.Count
Set aRange = ActiveDocument.Paragraphs(intParaCount).range
Set oRngBounds = aRange.Duplicate
With aRange.Find
Do
.Text = "shall" ' the word I am looking for
.Execute
If .Found And aRange.InRange(oRngBounds) Then
lngPage = aRange.Information(wdActiveEndPageNumber)
aRange.Expand Unit:=wdSentence
aRange.Copy
Debug.Print aRange
aRange.Collapse wdCollapseEnd

'objSheet.Cells(intRowCount, 1) = intParaCount & " - Page: " & lngPage
objSheet.Cells(intRowCount, 1) = lngPage 'I removed the paracount b/c I only need page number
objSheet.Cells(intRowCount, 3).Select

objSheet.Paste
intRowCount = intRowCount + 1
Set oRng = Selection.range
While oRng.ListParagraphs.Count = 0
oRng.MoveStart Unit:=wdParagraph, Count:=-1
oRng.Select
Wend
While oRng.ListParagraphs(1).range.ListFormat.ListType = 2
oRng.MoveStart Unit:=wdParagraph, Count:=-1
oRng.Select
Wend
objSheet.Cells(intRowCount, 2) = oRng.ListParagraphs(1).range.ListFormat.ListString

End If
Loop While .Found
End With
Next intParaCount
If Not objSheet Is Nothing Then
objSheet.usedrange.Columns.AutoFit
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub

[gmaxey]

What exactly are you trying to do?

[dbowlds]

I'm trying to search though a document, looking for each sentence that contains the word "shall." Then have the program create a spreadsheet with 3 columns: 1) The page number that the shall statement was found on, 2) The heading number in which the shall statement resides, and 3) The sentence itself containing the shall statement. The two forum programs mentioned (both of which you authored!) each does part of this. One does Items 1 and 3, and the other does item 2. I was hoping to combine them into a single program.

[gmaxey]

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

[dbowlds]

Greg, good catch. You are right, I don't care about bullet items, only headings. When I run the above code (your latest posting), I get a requested member of the collection does not exist on this line:
oSheet.Cells(lngRowCount, 2) = oRngHeader.ListParagraphs(1).Range.ListFormat.ListString

[gmaxey]

Then your document does not have a paragraph that meets this condition:

oRngHeader.Paragraphs(1).Range.ListFormat.ListType = 3 Or oRngHeader.Paragraphs(1).Range.ListFormat.ListType = 4

between the word shall and the start of the document.

It is hard to write code for a requirement you can't see and isn't fully explained.

[dbowlds]

Greg, my sincere apologies. It would have been smarter of me to instead have asked the question: How can the below code (your code from the 3/13 @ 11:50 post above) be modified to add another column to the Excel spreadsheet which contains the heading number associated with the found shall statement?

Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
Dim intParaCount As Integer
Dim oRngBounds As Range
If objSheet Is Nothing Then
Dim lngPage As Long
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xlsx
Set objSheet = appExcel.workbooks.Open("D:\test.xlsx").Sheets("Sheet1")
intRowCount = 1
objSheet.Cells(intRowCount, 1) = "Paragraph Number"
objSheet.Cells(intRowCount, 2) = "Sentence Text"
intRowCount = intRowCount + 1
End If

For intParaCount = 1 To ActiveDocument.Paragraphs.Count
Set aRange = ActiveDocument.Paragraphs(intParaCount).Range
Set oRngBounds = aRange.Duplicate
With aRange.Find
Do
.Text = "shall" ' the word I am looking for
.Execute
If .Found And aRange.InRange(oRngBounds) Then
lngPage = aRange.Information(wdActiveEndPageNumber)
aRange.Expand Unit:=wdSentence
aRange.Copy
Debug.Print aRange
aRange.Collapse wdCollapseEnd

objSheet.Cells(intRowCount, 1) = intParaCount & " - Page: " & lngPage
objSheet.Cells(intRowCount, 2).Select
objSheet.Paste
intRowCount = intRowCount + 1
End If
Loop While .Found
End With
Next intParaCount
If Not objSheet Is Nothing Then
objSheet.usedrange.Columns.AutoFit
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub

[SamT]

Greg,

PM me when this is done and I will close the thread

Sam