Sub BoldPolicyWords()
Dim wordsToBold() As String
Dim lngIndex As Long
Dim oRng As Range
wordsToBold = Split("Word1,Word2,Word3", ",")
  For lngIndex = 0 To UBound(wordsToBold)
    Set oRng = ActiveDocument.Range
    With oRng.Find
     .Text = wordsToBold(lngIndex)
     .Replacement.Font.Bold = True
     .Forward = True
     .Wrap = wdFindStop
     .MatchWholeWord = True
     .Execute Replace:=wdReplaceAll
    End With
    Set oRng = ActiveDocument.Range
    With oRng.Find
     .Text = "[^0147^34]" & wordsToBold(lngIndex) & "[^0148^34]"
     .Replacement.Font.Bold = False
     .Forward = True
     .Wrap = wdFindStop
     .MatchWildcards = True
     .MatchWholeWord = True
     Do While .Execute
       With oRng
        .MoveEnd Unit:=wdCharacter, Count:=-1
        .MoveStart Unit:=wdCharacter, Count:=1
        .Font.Bold = False
        .Collapse wdCollapseEnd
       End With
     Loop
    End With
  Next lngIndex
End Sub