Remove the line
from my macro and it will apply the font to all capitalised Words to the end of the document.
If you prefer to do them one at a time, then set the selection to the end of the word you have just processed e.g.
Sub Macro1()
Dim oRng As Range
Dim i As Long
Set oRng = ActiveDocument.Range
oRng.Start = Selection.Range.Start
For i = 2 To oRng.Words.Count
If oRng.Words(i).Case = wdUpperCase And Len(oRng.Words(i)) > 2 Then
oRng.Words(i).Font.Name = "Arial Black"
oRng.Start = oRng.Words(i).End
oRng.Collapse 1
oRng.Select
Exit For
End If
Next i
Set oRng = Nothing
End Sub
However if you want to format them all, replace is much faster
Sub Macro2()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Replacement.Font.Name = "Arial Black"
.Execute findText:="[ABCDEFGHIJKLMNOPQRSTUVWXYZ]{2,}", _
MatchWildcards:=True, _
Replace:=wdReplaceAll
End With
Set oRng = Nothing
End Sub