Finding words between two headings
Hello, this one has been driving me nuts.
I have a listbox (lbParsedTerms) that contains some search words and/or phrases. The user selects two or more equal level heading items (such as 4 heading level 3 entries) in a listbox that presents the table of contents for the activedocument. The myHeading string represents the specific custom style for the selected heading level.
The process is the first heading text in the lbTOC is searched for (less the number characters on the left to ensure the tab separator between the heading number and the heading text is excluded). Range (r1) is then used to mark the start of the desired text. Next the code looks for the 2nd item in the lbTOC. Once found, the contents between the first heading and the second (equal) heading is put into a range (r2) which is searched for each of the search terms contained in the lbParsedTerms listbox. The results are then presented in the lbSearchResults listbox. Then the next loop (myMainLoop) happens, moving down the lbTOC listing.
So, here is the problem I am having. The first search works in each instance, finding the right starting spot. But the terms search counts all instances of the terms to the end of the document versus stopping the search when it reaches the next equal heading. So, the first myMainLoop counts all the instances of, say "test" to the end of the document. Then, the next myMainloop starts at the right heading, and counts all the instances of "test" the to end of the document, and so forth, each time progressively getting smaller results. I think r2 is not getting set properly but cannot for the life of me figure out why.
Any assistance would be MOST appreciated. Here is the code.
Code:
Dim myLoop As Long, myCounter As Long, myMainLoop as Long
Dim myHeading As String
'determine the search range and search for the search terms from the list box within that range
For myMainLoop = 0 To lbTOC.ListCount - 2 'We do not want to process the last item as it is considered a dummy
lbSearchResults.AddItem lbTOC.List(myMainLoop) & " Results:"
Selection.WholeStory
Selection.Collapse wdCollapseStart
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles(myHeading)
With Selection.Find
'MsgBox "searching for: " & Right(lbTOC.List(myMainLoop), (Len(lbTOC.List(myMainLoop)) - myLen))
.Text = Right(lbTOC.List(myMainLoop), (Len(lbTOC.List(myMainLoop)) - myLen))
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
End With
Selection.Find.Execute
Selection.Collapse wdCollapseStart
Dim r1 As range
Set r1 = Selection.range
'keep format settings, only change search text
'MsgBox "searching for: " & Right(lbTOC.List(myMainLoop + 1), (Len(lbTOC.List(myMainLoop + 1)) - myLen))
Selection.Find.Text = Right(lbTOC.List(myMainLoop + 1), (Len(lbTOC.List(myMainLoop + 1)) - myLen))
If Selection.Find.Execute Then
Selection.Collapse wdCollapseStart
'Debug.Print Selection.Text
Else
Selection.WholeStory
Selection.Collapse wdCollapseEnd
End If
Dim r2 As range
'loop through the search terms
myLBCounter = lbSearchResults.ListCount
For myLoop = 0 To lbParsedTerms.ListCount - 1
Set r2 = ActiveDocument.range(r1.Start, Selection.Start)
With r2.Find
.Text = lbParsedTerms.List(myLoop)
.Font.Hidden = False 'skip any hidden fonts
myCounter = 0
Do While .Execute(Forward:=True) = True
myCounter = myCounter + 1
Loop
With lbSearchResults
.AddItem
.List(myLBCounter + myLoop, 0) = lbParsedTerms.List(myLoop)
.List(myLBCounter + myLoop, 1) = myCounter 'number of positive "hits"
End With
End With
Next
Next myMainLoop
