Поиск и замена текста в надписях - VBA

Формулировка задачи:

Здравствуйте. Необходимо решить проблему в крайние сроки. Может решение у меня под носом, но голова не варит( В общем есть документ вордовский и в нем я сделал надписи в автофигурах. Мне необходимо сделать макрос по поиску и замене надписей в этих автофигурах. нашел код, сделал, но поиск и замена надписи происходит только в первой автофигуре. вот код:

Dim myStoryRange As Range
  For Each myStoryRange In ActiveDocument.StoryRanges
    With myStoryRange
      With .Find
        .Text = "текст надписи"
        .Replacement.Text = "на какой необходимо заменить"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
End With
End With
  Next myStoryRange

Код не полный, так как тот который я нашел не работает, вся программа зависает и приходится перезапускать. Вот полный код.

Dim myStoryRange As Range
  For Each myStoryRange In ActiveDocument.StoryRanges
    With myStoryRange
      With .Find
        .Text = "текст надписи"
        .Replacement.Text = "на какой необходимо заменить"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
      While Not (.NextStoryRange Is Nothing)
        Set myStoryRange = .NextStoryRange
        With .Find
          .Text = "текст надписи"
        .Replacement.Text = "на какой необходимо заменить"
          .Forward = True
          .Wrap = wdFindContinue
          .Format = True
          .MatchCase = False
          .MatchWholeWord = False
          .MatchWildcards = False
          .MatchSoundsLike = False
          .MatchAllWordForms = False
          .Execute Replace:=wdReplaceAll
        End With
      Wend
    End With
  Next myStoryRange

и да кстати стандартными средствами поиска и замены все получается, но мне необходим макрос. записывал, но все равно та же беда(

Решение задачи: «Поиск и замена текста в надписях»

textual
                            Листинг программы 
                        

                            Dim rng As Range
Dim sh As Shape
Dim str As String
 
For Each sh In ActiveDocument.Shapes
   With sh.TextFrame
      If .HasText <> 0 Then
         Set rng = .TextRange
         With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = "Что заменить"
            .Replacement.Text = "На что заменить"
            .Forward = True
            .Wrap = wdFindContinue
            .MatchCase = False
            .Execute Replace:=wdReplaceAll
         End With
      End If
   End With
Next sh
                        