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
ResetFRParameters 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
    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
            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
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range)
With rngStory.Find
  .Font.Bold = True
  While .Execute
    rngStory.HighlightColorIndex = wdGreen
    DoEvents
  Wend
End With
End Sub
Sub ResetFRParameters(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