宏（VBA）崩溃Microsoft word（查找并替换）

Question

我使用VBA代码批量查找和替换高亮显示的文本。宏查找并替换文档中的单词。它适用于小文档（1-2页）上的一些突出显示的文本。然而，当我在一个超过100页的大型文档上使用这个宏时，微软的word崩溃了，变得没有反应，所以我不得不被迫退出。

代码是为了帮助编辑信息变得容易。我用XXXXX和高亮黑色替换表格中也出现的高亮文本。

有没有人能提供一些技巧来提高代码的效率？

这是密码

Sub FindandReplaceHighlight()
  Dim strFindColor As String
  Dim strReplaceColor As String
  Dim strText As String
  Dim objDoc As Document
  Dim objRange As Range
 
  Application.ScreenUpdating = False
 
  Set objDoc = ActiveDocument
 
  strFindColor = InputBox("Specify a color (enter the value):", "Specify Highlight Color")
  strReplaceColor = InputBox("Specify a new color (enter the value):", "New Highlight Color")
  strText = InputBox("Specify a new text (enter the value):", "New Text")
  
  With Selection
    .HomeKey Unit:=wdStory
    With Selection.Find
      .Highlight = True
 
      Do While .Execute
        If Selection.Range.HighlightColorIndex = strFindColor Then
          Set objRange = Selection.Range
          objRange.HighlightColorIndex = strReplaceColor
          objRange.Text = strText
          objRange.Font.ColorIndex = wdBlack
          Selection.Collapse wdCollapseEnd
        End If
      Loop
    End With
  End With
 
  Application.ScreenUpdating = True
End Sub

Answer 1

尝试：

Sub FindandReplaceHighlight()
Application.ScreenUpdating = False
Dim ClrFnd As Long, ClrRep As Long, strTxt As String
Const StrColors As String = vbCr & _
"  1 Black" & vbCr & _
"  2  Blue" & vbCr & _
"  3  Turquoise" & vbCr & _
"  4  Bright Green" & vbCr & _
"  5  Pink" & vbCr & _
"  6  Red" & vbCr & _
"  7  Yellow" & vbCr & _
"  8  White" & vbCr & _
"  9  Dark Blue" & vbCr & _
"10 Teal" & vbCr & _
"11 Green" & vbCr & _
"12 Violet" & vbCr & _
"13 Dark Red" & vbCr & _
"14 Dark Yellow" & vbCr & _
"15 Gray 50" & vbCr & _
"16 Gray 25%"
 
ClrFnd = InputBox("Specify the old color (enter the value):" & StrColors, "Specify Highlight Color")
ClrRep = InputBox("Specify the new color (enter the value):" & StrColors, "New Highlight Color")
strTxt = InputBox("Specify the new text (enter the value):", "New Text")
  
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Highlight = True
      .Forward = True
      .Wrap = wdFindStop
    End With
    Do While .Find.Execute
      If .HighlightColorIndex = ClrFnd Then
        .HighlightColorIndex = ClrRep
        .Text = strTxt
        .Font.ColorIndex = wdBlack
        .Collapse wdCollapseEnd
      End If
    Loop
  End With
End With
Application.ScreenUpdating = True
End Sub