Макрос для поиска сокращений в документе ворд

Вариант 1. Базовый поиск сокращений (2–5 заглавных букв)

Sub FindAbbreviations()
Dim docSource As Document
Dim docResult As Document
Dim rng As Range
Dim dictAbbreviations As Object
Dim abbreviation As Variant

' Инициализация словаря для уникальных сокращений
Set dictAbbreviations = CreateObject("Scripting.Dictionary")

' Устанавливаем текущий документ как источник
Set docSource = ActiveDocument
Set rng = docSource.Content

' Настройка поиска
With rng.Find
.ClearFormatting
.Text = "<[A-Z]{2;5}>" ' Исправленный шаблон: 2–5 заглавных латинских букв
.MatchWildcards = True
.Forward = True
.Wrap = wdFindStop
End With

' Поиск всех сокращений
Do While rng.Find.Execute
If Not dictAbbreviations.Exists(rng.Text) Then
dictAbbreviations.Add rng.Text, 1
End If
rng.Collapse wdCollapseEnd
Loop

' Создаём новый документ для результатов
Set docResult = Documents.Add
docResult.Content.Text = "Список сокращений:" & vbCrLf & vbCrLf

' Добавляем найденные сокращения
For Each abbreviation In dictAbbreviations.Keys
docResult.Content.InsertAfter abbreviation & vbCrLf
Next abbreviation

MsgBox "Найдено " & dictAbbreviations.Count & " уникальных сокращений"
End Sub

Вариант 2. Поиск сокращений с поддержкой кириллицы

Если в документе есть русские сокращения:

Sub FindRussianAbbreviations()
Dim docSource As Document
Dim docResult As Document
Dim rng As Range
Dim dictAbbreviations As Object
Dim abbreviation As Variant

Set dictAbbreviations = CreateObject("Scripting.Dictionary")
Set docSource = ActiveDocument
Set rng = docSource.Content

With rng.Find
.ClearFormatting
.Text = "<[А-ЯЁ]{2;5}>" ' Русские заглавные буквы, 2–5 символов
.MatchWildcards = True
.Forward = True
.Wrap = wdFindStop
End With

Do While rng.Find.Execute
If Not dictAbbreviations.Exists(rng.Text) Then
dictAbbreviations.Add rng.Text, 1
End If
rng.Collapse wdCollapseEnd
Loop

' Создание результата
Set docResult = Documents.Add
docResult.Content.Text = "Русские сокращения:" & vbCrLf & vbCrLf

For Each abbreviation In dictAbbreviations.Keys
docResult.Content.InsertAfter abbreviation & vbCrLf
Next abbreviation

MsgBox "Найдено " & dictAbbreviations.Count & " русских сокращений"
End Sub

Вариант 3. Комбинированный поиск (латиница + кириллица)

Для документов с сокращениями на обоих языках:

Sub FindAllAbbreviations()
Dim docSource As Document
Dim docResult As Document
Dim rng As Range
Dim dictAbbreviations As Object
Dim abbreviation As Variant
Dim patterns As Variant
Dim pattern As Variant

Set dictAbbreviations = CreateObject("Scripting.Dictionary")
Set docSource = ActiveDocument
Set rng = docSource.Content

' Шаблоны для поиска
patterns = Array("<[A-Z]{2;5}>", "<[А-ЯЁ]{2;5}>")

For Each pattern In patterns
With rng.Find
.ClearFormatting
.Text = pattern
.MatchWildcards = True
.Forward = True
.Wrap = wdFindStop
End With

Do While rng.Find.Execute
If Not dictAbbreviations.Exists(rng.Text) Then
dictAbbreviations.Add rng.Text, 1
End If
rng.Collapse wdCollapseEnd
Loop
Next pattern

' Вывод результатов
Set docResult = Documents.Add
docResult.Content.Text = "Все сокращения (латиница + кириллица):" & vbCrLf & vbCrLf

For Each abbreviation In dictAbbreviations.Keys
docResult.Content.InsertAfter abbreviation & vbCrLf
Next abbreviation

MsgBox "Найдено " & dictAbbreviations.Count & " сокращений"
End Sub