Есть ли способ оптимизировать этот код?Это медленно и мерцает экран

Question

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

Public Sub FindReplaceAnywhere(ByRef strTrigrame As String)

    Dim rngStory As Word.Range
    Dim pFindTxt As String
    Dim pReplaceTxt As String
    Dim lngJunk As Long
    Dim oShp As Shape

    Application.ScreenUpdating = False
'  pFindTxt = InputBox("Entrez le Trigramme du site ." _
'    , "FIND")
'  If pFindTxt = "" Then
'    MsgBox "Cancelled by User"
'    Exit Sub
'  End If
    pFindTxt = "TRIGRAMME"
TryAgain:
    strTrigrame = InputBox("Entrez le Trigramme du site en MAJUSCULES.", "REPLACE")
    If strTrigrame = "" Then
        If MsgBox("Do you just want to delete the found text?", _
        vbYesNoCancel) = vbNo Then
        GoTo TryAgain
    ElseIf vbCancel Then
        MsgBox "Cancelled by User."
        Exit Sub
    End If
End If

'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
    Do
        SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
        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 oShp.TextFrame.HasText Then
                        SearchAndReplaceInStory oShp.TextFrame.TextRange, _
                        pFindTxt, strTrigrame
                    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
Application.ScreenUpdating = True
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
    ByVal strSearch As String, ByVal strReplace As String)

    With rngStory.Find

        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = strSearch
        .Replacement.Text = strReplace
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll

    End With

End Sub

Если кто-нибудь может помочь мне оптимизировать этот код и, возможно, решить проблему мерцания, я был бы признателен.Заранее спасибо.