Здравствуйте!
Помогите пожалуйста с макросом, который подсчитывает количество абзацев со стилями. Если не сложно, хотелось бы видеть в конце сообщение:
Абзацев со стилями:
Обычный - 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
Вывод очень удобный! Большое спасибо!
В конце у меня выводит:
Текст сноски;Текст сноски-FN;Знак Знак1;Текст сноски Знак1 Знак;Текст сноски Знак Знак Знак;Знак Знак1 Знак;Знак1;Текст сноски Знак1 Знак Знак Знак;Текст сноски Знак Знак Знак Знак Знак;Reference;Footnote Text Ch;Знак; Знак;Знак Знак Знак;Знак Знак - 22
Это значит нет абзацев с такими стилями?
Цитата:
Это значит нет абзацев с такими стилями?
С какими стилями?
С перечисленными.
Например
Текст сноски Знак Знак Знак
Или это особенный стиль такой?
Наверное, это и есть такой стиль.
Ясно. Спасибо!
Внёс ещё изменение в макрос в ответе #1.
Я не знаю, почему у стиля создаётся такое имя.
Спасибо! Уже пригодилось!