Here is another variation. Not better just different:
Code:
Sub Demo()
Dim oRng As Word.Range
Dim i As Long, j As Long
Dim bFound As Boolean
Application.ScreenUpdating = False
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "<[A-Z][! ]@>"
.Wrap = wdFindStop
.MatchWildcards = True
While .Execute
bFound = True
oRng.MoveEnd wdWord, 6
For i = 2 To oRng.Words.Count
If Not oRng.Words(i).Characters(1) Like "[A-Z]" Then bFound = False
Next
If bFound = True Then
j = j + 1
MsgBox oRng.Text
End If
oRng.Collapse wdCollapseEnd
Wend
End With
Application.ScreenUpdating = True
MsgBox j & " instances found."
End Sub