Highlighting specific words within a selected range - vba

Question

I am trying to select a range between two words, find a word within the found range and finally color that word.
In the image I want to select range between "Observation" and "Supporting Information" and then search for "Management" words and color them red.
With my code I am able to highlight the first occurrence of the word.
Sub RevisedFindIt4()
' Purpose: highlight the text between (but not including)
' the words "Observation:" and "Supporting Information:" if they both appear.
Dim rng1 As Range
Dim rng2 As Range
Dim rngFound As Range
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set rng1 = ActiveDocument.Range
If rng1.Find.Execute(FindText:="Observation:") Then
Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
If rng2.Find.Execute(FindText:="Supporting Information:") Then
Set rngFound = ActiveDocument.Range(rng1.End, rng2.Start)
If rngFound.Find.Execute(FindText:="Management") Then
rngFound.Select
Selection.Range.HighlightColorIndex = wdRed
End If
End If
End If
Selection.HomeKey wdStory
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 1

A modified version of your code using Find to highlight the text.
Sub RevisedFindIt4()
' Purpose: highlight the text between (but not including)
' the words "Observation:" and "Supporting Information:" if they both appear.
Dim rng1 As Range
Dim rng2 As Range
Dim rngFound As Range
Dim highlightIndex As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'capture current highlight color so that it can be reset later
highlightIndex = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdRed
Set rng1 = ActiveDocument.Range
If rng1.Find.Execute(FindText:="Observation:") Then
Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
If rng2.Find.Execute(FindText:="Supporting Information:") Then
Set rngFound = ActiveDocument.Range(rng1.End, rng2.Start)
With rngFound.Find
.Replacement.highlight = True
.Execute Replace:=wdReplaceAll, Forward:=True, FindText:="Management", ReplaceWith:="", Format:=True
End With
End If
End If
Options.DefaultHighlightColorIndex = highlightIndex
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 2

The Find method in word can be a bit tricky to manage. What you want to achieve must be done with two searches inside a loop. The first search finds the next 'Observation:', the Second Finds the following 'Supporting Information:'. You then use the end of the first search and the start of the second search to generate the range that needs to be made 'wdRed'
The following code works well on my PC
Option Explicit
Sub RevisedFindIt4()
' Purpose: highlight the text between (but not including)
' the words "Observation:" and "Supporting Information:" if they both appear.
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False
Dim myOuterRange As Word.Range
Set myOuterRange = ActiveDocument.StoryRanges(wdMainTextStory)
With myOuterRange
Do
With .Find
.ClearFormatting
.MatchWildcards = True
.Text = "(Observation)([: ]{1,})(^13)"
.Wrap = wdFindStop
If Not .Execute Then Exit Do
End With
Dim mystart As Long
mystart = .End
.Collapse direction:=wdCollapseEnd
.Move unit:=wdCharacter, Count:=1
myOuterRange.End = ActiveDocument.StoryRanges(wdMainTextStory).End
With .Find
.ClearFormatting
.MatchWildcards = True
.Text = "^13Supporting Information"
.Wrap = wdFindStop
If Not .Execute Then Exit Do
End With
Dim myEnd As Long
myEnd = .Start
ActiveDocument.Range(mystart, myEnd).Font.ColorIndex = wdRed
.Collapse direction:=wdCollapseEnd
.Move unit:=wdCharacter, Count:=1
myOuterRange.End = ActiveDocument.StoryRanges(wdMainTextStory).End
Loop
End With
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
End Sub
UPDATE
This is the code I first wrote. I blame a biscuit (cookie) shortage for misreading the post the second time and revising my code to the first provided.
Sub RevisedFindIt4()
' Purpose: highlight the text between (but not including)
' the words "Observation:" and "Supporting Information:" if they both appear.
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False
Dim myOuterRange As Word.Range
Set myOuterRange = ActiveDocument.StoryRanges(wdMainTextStory)
With myOuterRange
Do
With .Find
.ClearFormatting
.MatchWildcards = True
.Text = "(Observation:)(*)(Supporting Information:)"
.Wrap = wdFindStop
If Not .Execute Then Exit Do
End With
Dim myInnerRange As Word.Range
Set myInnerRange = .Duplicate
With myInnerRange
With .Find
.Text = "Management"
.Replacement.Font.ColorIndex = wdRed
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
End With
.Collapse Direction:=wdCollapseEnd
.Move unit:=wdCharacter, Count:=1
myOuterRange.End = ActiveDocument.StoryRanges(wdMainTextStory).End
Loop
End With
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
End Sub