Sub ALLCAPS_TO_SMALLCAPS()
Application.ScreenUpdating = False
Dim oRng As Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<[A-Z][A-Z]*>"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    While .Execute
      oRng.Select
      If MsgBox("Reformat?", vbQuestion + vbYesNo) = vbYes Then
        oRng.Case = wdTitleWord
        oRng.Font.SmallCaps = True
      End If
      oRng.Collapse wdCollapseEnd
    Wend
  End With
Application.ScreenUpdating = True
End Sub