Sub InitialCapOnly()
' Paul Beverley - Version 29.05.10
' Reduce all-capitals to initial cap
' Crtl-Alt-I

oldFind = Selection.Find.Text
oldReplace = Selection.Find.Replacement.Text

Selection.MoveStart wdCharacter, 1
Selection.MoveEnd wdWord, 1
Selection.MoveStart wdWord, -1

Selection.Range.Case = wdTitleWord
Selection.Start = Selection.End
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[A-Z][A-Z][A-Z][A-Z]"
  .MatchWildcards = True
  .Execute
End With

With Selection.Find
  .Text = oldFind
  .Replacement.Text = oldReplace
  .MatchWildcards = False
End With
End Sub