Find and highlight formatting - issue with big documents

[rook]

Rook,

Seems to work fine here:
Results.jpg

But if you want skip the TextFrame story, see below and unstet the appropriate line:

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape

'Fix the skipped blank Header/Footer problem
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  For lngJunk = 1 To 3
    ResetFRParams Selection.Range
    
    'Iterate through all story types in the current document
    For Each rngStory In ActiveDocument.StoryRanges
      'Iterate through all linked stories
      Do
        'If rngStory.StoryType = 5 Then Exit Do
        SrcAndRplInStory rngStory, lngJunk
        
        On Error Resume Next
        Select Case rngStory.StoryType
          Case 6, 7, 8, 9, 10, 11
            If rngStory.ShapeRange.Count > 0 Then
              For Each oShp In rngStory.ShapeRange
                If Not oShp.TextFrame.TextRange Is Nothing Then
                  SrcAndRplInStory oShp.TextFrame.TextRange, lngJunk
                End If
              Next
            End If
          Case Else
            'Do Nothing
        End Select
        On Error GoTo 0
        'Get next linked story (if any)
        Set rngStory = rngStory.NextStoryRange
      Loop Until rngStory Is Nothing
    Next
  Next lngJunk
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, lngRouter As Long)
  With rngStory.Find
    Select Case lngRouter
      Case 1
        .Font.Bold = True
        While .Execute
          rngStory.HighlightColorIndex = wdGreen
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 2
        .Font.Italic = True
        While .Execute
          rngStory.HighlightColorIndex = wdRed
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
      Case 3
        .Font.Underline = wdUnderlineSingle
        While .Execute
          rngStory.HighlightColorIndex = wdYellow
          rngStory.Collapse wdCollapseEnd
          DoEvents
        Wend
    End Select
  End With
End Sub
Sub ResetFRParams(oRng As Range)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub

Hi Greg, thank you. On my end it doesn't highlight text in the frame example1.jpg(1). I tried the code you just shared and on my end it stucks in the first "Do Events" (2) and in the big document it again gives the Error 4605 (3).

Any advice on what could be causing that behavior since it is behaving correctly on your end?

Thank you!