Highlighting specific words within a selected range

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