Search the TextFrameStory ranges.
Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Range
Dim oTbl As Table
Dim arrTerm() As String
Dim arrCI(3) As Long
Dim lngIndex As Long
arrTerm = Split("Rarely,Sometimes,Often,Consistently", ",")
arrCI(0) = wdColorRed: arrCI(1) = wdColorOrange: arrCI(2) = wdColorYellow: arrCI(3) = wdColorGreen
For lngIndex = 0 To UBound(arrTerm)
Set oRng = ActiveDocument.StoryRanges(wdTextFrameStory)
Do
With oRng.Find
.Text = arrTerm(lngIndex)
While .Execute
Set oTbl = Nothing
On Error Resume Next
Set oTbl = oRng.Tables(1)
If Not oTbl Is Nothing Then
oRng.Cells(1).Shading.BackgroundPatternColor = arrCI(lngIndex)
oRng.Collapse wdCollapseEnd
End If
Wend
End With
Set oRng = oRng.NextStoryRange
Loop Until oRng Is Nothing
Next lngIndex
lbl_Exit:
Exit Sub
End Sub