Didn't work here. (Word 016). Try this:
Sub HighlightCapitalWordsYellow() Dim objRange As Range With Selection With Selection.Find .ClearFormatting .Text = "[A-Z]{1, }" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchWildcards = True .Execute End With Do While .Find.Found Set objRange = Selection.Range objRange.HighlightColorIndex = wdYellow .Collapse wdCollapseEnd .Find.Execute Loop End With End Sub