Поиск слов с прописными буквами

Роман интересуется:

Можно воспользоваться следующим макросом, который мне помогли реализовать специалисты VBA с форума microsoft.public.word.vba.general.

Этот макрос позволяет найти в документе все слова, написанные прописными буквами, скопировать их в конец документа, отсортировать по алфавиту и удалить повторяющиеся слова. При этом, не затрагиваются односимвольные слова, типа О, И и так далее.

Sub UcaseList()
'Поиск в тексте слов с прописными буквами, копирование их в конец документа, сортировка и удаление повторяющихся
'Помощь от Jean-Guy Marcil и Graham Mayor
'http://groups.google.ru/group/microsoft.public.word.vba.general/
Dim rngDoc As Word.Range
Dim wu As Word.Range
Dim lngDocEnd As Long
Set rngDoc = ActiveDocument.Range
lngDocEnd = rngDoc.End
With ActiveDocument
   Selection.EndKey Unit:=wdStory  'переходим в конец документа
   Selection.TypeParagraph   'вставляем параграф
   .Bookmarks.Add Range:=Selection.Range, Name:="ListStart"   'вставляем закладку
   'для каждого слова проверяем его регистр и если есть слова с прописными буквами, добавляем их в конец документа
   For Each wu In rngDoc.Words
      If wu.Case = wdUpperCase Then
         .Range.InsertAfter vbCrLf & wu.Text
         rngDoc.End = lngDocEnd
      End If
   Next wu
   .Bookmarks("ListStart").Select  'выбираем закладку, выделяем все слова, что идут ниже ее, и сортируем их по алфавиту
   With Selection
      .EndKey Unit:=wdStory, Extend:=wdExtend
      .Sort , FieldNumber:="Paragraphs", _
      SortFieldType:=wdSortFieldAlphanumeric, _
      SortOrder:=wdSortOrderAscending
      'с отсортированными словами
      With .Find
         .ClearFormatting
         .Replacement.ClearFormatting
      'удаляем пробелы после слов
         .Text = "[ ](^13)"
         .Replacement.Text = "\1"
         .MatchWildcards = True
         .Execute Replace:=wdReplaceAll
      'удаляем лишние концы абзацев
         .Text = "(*^13)@"
         .Replacement.Text = "\1"
         .MatchWildcards = True
         .Execute Replace:=wdReplaceAll
      'ищем повторяющиеся слова и удаляем их
         .Text = "([!A-Z-А-ЯЁ])[A-Z-А-ЯЁ]^13"
         .Replacement.Text = "\1"
         .Execute Replace:=wdReplaceAll
      End With
   End With
End With
End Sub

Если вы не знаете, как подключить к документу и применить этот макрос, изучите следующие заметки с сайта:

Создание макроса из готового кода

Автоматическая запись макроса