Word document highlight issues - vba

Question

Hi I am very new to VBA word programming. I am trying to use regex and word range to select a pattern of words in a word document containing 108 pages to highlight them in Yellow and Green. When I execute the VBA code the word document hangs for a minute of 2 until the code has processed the request. Please check the code below and suggest.
**extract of the word**
*QR233A(M/W)
if LRD233 xs , LRD237 xs
LRDE233 xs , LRDE237 xs
then #R233A(M/W)
\
.
*QZR233A(M/W) #R233A(M/W) .
*QAR233A(M/W)
if LRD233 xs , LRD237 xs
LRDE233 xs , LRDE237 xs
LARSUDKFTHJS s , LARSUDKFLMS s
then #R233A(M/W)
\
.
*R233A(M/W)
if R233A(M/W) a
P831 cnf , P833 cnf , L(PB-1)SETTINGAVAIL xs
LSGPBA xs
then R233A(M/W) s
P831 cn , P833 cn
**VBA Code**
Sub Reminder_Highlight()
Dim match As VBScript_RegExp_55.match
Dim matches As VBScript_RegExp_55.MatchCollection
Dim myrange As Range
Dim rng3 As Selection
Dim counter As Integer
Set myrange = ActiveDocument.Content
Set rng3 = Selection
Dim Panel_request As Boolean
Dim Reminder_latch As Boolean
With New VBScript_RegExp_55.RegExp
.Pattern = "(\*Q(A|R|RD)\S+|LRD\S+\s(xs\s+,|xs)|(\#R|\*R)\S+)"
.Global = True
Set matches = .Execute(rng3.Text)
End With
Debug.Print matches.Count
For Each match In matches
myrange.SetRange rng3.Characters(match.FirstIndex + 1).Start, rng3.Characters(match.FirstIndex + match.Length).End
If Left(match, 1) = "#" Or Mid(match, 1, 2) = "*R" Then myrange.HighlightColorIndex = wdBrightGreen Else myrange.HighlightColorIndex = wdYellow
Debug.Print matches.Item(counter) & " "; counter
counter = counter + 1
Next
Set matches = Nothing
Set rng2 = Nothing
Set rng1 = Nothing
Set rng3 = Nothing
End Sub

Answer 1

Try this.
Sub HighlightSpecificWords()
Dim sArr() As String
Dim rTmp As Range
Dim x As Long
sArr = Split("highlight specific words") ' your list
Options.DefaultHighlightColorIndex = wdYellow
For x = 0 To UBound(sArr)
Set rTmp = ActiveDocument.Range
With rTmp.Find
.Text = sArr(x)
.Replacement.Text = sArr(x)
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
Next
End Sub
Before:
After: