有没有一种优化此代码的方法？速度慢，屏幕闪烁

Question

我正在尝试在Word文档正文和页眉/页脚中搜索一个字符串，然后将其替换为另一个。该代码运行良好，但是速度很慢，并且在更改文档时屏幕闪烁。

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

如果有人可以帮助我优化此代码，并解决闪烁的问题，我将不胜感激。预先感谢。