Hi ExpatChic,
Try the following. I had to make some changes to your code, as it wasn't working.
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim vFindText As String, vColor As String, x As Long
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
'Insert Page breaks before the paragraphs preceding the 'Cat #' paragraphs
.Text = "[!^13]{1,}^13Cat I"
.Replacement.Text = "^m^&"
.Execute Replace:=wdReplaceAll
'Delete any duplicate page breaks
.Text = "[^m]{2,}"
.Replacement.Text = "^m"
.Execute Replace:=wdReplaceAll
'Highlight the 'Cat #' paragraphs
.Replacement.Text = "^&"
.Replacement.Highlight = True
For x = 1 To 3
Select Case x
Case Is = 1
vFindText = "Cat I^13"
vColor = wdRed
Case Is = 2
vFindText = "Cat II^13"
vColor = wdYellow
Case Is = 3
vFindText = "Cat III^13"
vColor = wdPink
End Select
Options.DefaultHighlightColorIndex = vColor
.Text = vFindText
.Execute Replace:=wdReplaceAll
Next x
Options.DefaultHighlightColorIndex = wdNoHighlight
End With
Application.ScreenUpdating = True
End Sub