Macro (VBA) crashing Microsoft word (Find and replace)

Question

I using a VBA code to batch find and replace highlighted text. The macro finds and replaces the words in the document. It works well with a few number of highlighted text on a small document (1-2 pages). However, when I use this macro on a large documents which has over a 100 pages, Microsoft word crashed and becomes unresponsive so I have to forced to quit.

The code is to help make it easy to redact information. I am replacing the highlight text which occur also in tables with XXXXX and highlighted black.

Does anyone have any tips to make the code more efficient?

Here is the code

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

You have a Do... Loop with an If condition, which if it is not true will just put it into an infinite loop, which causes the program to crash. That's my best guess. — braX
There is an add-in to Word called AuthorTec Redactor, I am the author. You can get information about it by doing a web search on the name. — Rich Michaels

macropod macropod · Accepted Answer · 2021-02-24T09:34:21

Try:

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

Macro (VBA) crashing Microsoft word (Find and replace)

1 Answers