Word VBA Макрос: Подсчитать количество абзацев со стилями

[Anton]

Здравствуйте!
Помогите пожалуйста с макросом, который подсчитывает количество абзацев со стилями. Если не сложно, хотелось бы видеть в конце сообщение:

Абзацев со стилями:
Обычный - 40
Заголовок1 - 5
Заголовок2 - 12 и т. п.

[Администратор]

Макрос выводит результат в ворд-файл.

Макрос

Sub макрос()

    Dim par As Paragraph, docRes As Document
    Dim clnStyles As Collection, clnCounters As Collection
    Dim count As Long, style As String, i As Long
   
   
    '1. Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '2. Создание коллекций. В коллекцию "clnStyles" будут записываться имена стилей,
        ' в коллекцию "clnCounters" их кол-во. В одной коллекции это сделать нельзя,
        ' т.к. нельзя извлечь данные из Keys.
    Set clnStyles = New Collection
    Set clnCounters = New Collection
   
    '3. Включение перехватчика ошибок. Ошибка будет происходить, если в коллекции уже есть стиль с таким именем.
    On Error Resume Next
   
    '4. Цикл по всем абзацам.
    For Each par In ActiveDocument.Paragraphs
   
        '1) Запись имени стиля в переменную, чтобы ускорить макрос, чтобы по несколько раз не обращаться к объекту "par",
            ' а брать данные сразу из переменной "style".
        style = par.style
       
        '2) Создание в коллекции "clnStyles" элемента.
        clnStyles.Add Item:=style, Key:=style
       
        '3) Создание в коллекции "clnCounters" элемента. В Item записывается число 1 на случай,
            ' если в коллекции ещё нет такого стиля.
        clnCounters.Add Item:=1, Key:=style
       
        '4) Если произошла ошибка, значит в коллекциях уже есть такой стиль.
            ' Просто увеличить число на 1 в коллекции нельзя, нужно удалить элемент, а затем создать заново.
        If Err.Number <> 0 Then
            'a) Сброс ошибки, чтобы в следующем витке цикла понять, произошла ошибка или нет.
            Err.Number = 0
            'b) Запоминание, сколько стиль уже встречался.
            count = clnCounters(style)
            'c) Удаление в коллекциях элементов с этим стилем.
            clnStyles.Remove style
            clnCounters.Remove style
            'd) Создание в коллекциях элементов для этого стиля.
            clnStyles.Add Item:=style, Key:=style
            clnCounters.Add Item:=count + 1, Key:=style
        End If
    Next par
   
    '5. Отключение перехватчика ошибок.
    On Error GoTo 0
   
    '6. Создание ворд-файла, в который запишется результат.
    Set docRes = Documents.Add
   
    '7. Копирование данных из коллекций в ворд-файл.
    For i = 1 To clnStyles.count
        docRes.Range.InsertAfter Text:=clnStyles(i) & " - " & clnCounters(i) & Chr(13)
    Next i
   
    '8. Удаление с конца пустого абзаца, чтобы при сортировке он не поднимался вверх.
    docRes.Range.Characters.Last.Delete
   
    '9. Сортировка стилей по возрастанию.
    docRes.Range.Sort ExcludeHeader:=False, FieldNumber:="абзацам", SortFieldType:=wdSortFieldAlphanumeric, _
        SortOrder:=wdSortOrderAscending, Separator:=wdSortSeparateByDefaultTableSeparator, SortColumn:=False, _
        CaseSensitive:=False, LanguageID:=wdRussian
   
    '10. Включение монитора.
    Application.ScreenUpdating = True

End Sub

[свернуть]

[Anton]

Вывод очень удобный! Большое спасибо!

В конце у меня  выводит:
Текст сноски;Текст сноски-FN;Знак Знак1;Текст сноски Знак1 Знак;Текст сноски Знак Знак Знак;Знак Знак1 Знак;Знак1;Текст сноски Знак1 Знак Знак Знак;Текст сноски Знак Знак Знак Знак Знак;Reference;Footnote Text Ch;Знак; Знак;Знак Знак Знак;Знак Знак - 22

Это значит нет абзацев с такими стилями?

[Администратор]

Цитата:
Это значит нет абзацев с такими стилями?

С какими стилями?

[Anton]

С перечисленными.
Например
Текст сноски Знак Знак Знак
Или это особенный стиль такой?

[Администратор]

Наверное, это и есть такой стиль.

[Anton]

Ясно. Спасибо!

[Администратор]

Внёс ещё изменение в макрос в ответе #1.

[Администратор]

Я не знаю, почему у стиля создаётся такое имя.

[Anton]

Спасибо! Уже пригодилось!