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
        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
    Case 2: .Font.Italic = True
    Case 3: .Font.Underline = wdUnderlineSingle
  End Select
  While .Execute
    rngStory.HighlightColorIndex = wdGreen
    DoEvents
  Wend
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