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

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

Answer 1

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