Работа с макросами: макрос для выгрузки комментариев в документ Excel

Алгоритм настройки и выполнения макроса

1. Откройте документ Microsoft Word.
2. Нажмите сочетание клавиш Alt + F11, чтобы открыть окно Microsoft Visual Basic для приложений (VBA).
3. В меню выберите «Вставка» → «Модуль» — это создаст новый модуль.
4. Скопируйте код VBA из исходного документа Word и вставьте его в окно созданного модуля.
5. Перед запуском макроса необходимо подключить библиотеку объектов Excel. Для этого в редакторе VBA откройте меню «Инструменты» → «Ссылки».
6. В открывшемся диалоговом окне «Ссылки» найдите в списке «Библиотека объектов Microsoft Excel» (версия может отличаться). Установите флажок рядом с этой библиотекой и нажмите OK.
7. Запустите макрос одним из способов:
   нажмите клавишу F5;
   либо выберите в меню Run → Run Sub/UserForm.
8. После выполнения макроса Microsoft Excel автоматически откроет новую книгу. В ней все комментарии из документа Word будут организованы в виде таблицы.

Макрос (его необходимо скопировать и вставить как есть):

Sub extractRevisions()

Dim revisionObj As Revision, commentObj As Comment, xlApp As Object, xlWs As Object

ThisDocument.Activate

ReDim transfArr(0 To ActiveDocument.revisions.Count + ActiveDocument.Comments.Count)

transfArr(0) = Array("Автор", "Создатель (?)", "Время изменения", "Тип", "Страница", "Текст", "Примечание/Правка")

For i = 1 To ActiveDocument.revisions.Count

Set revisionObj = ActiveDocument.revisions.Item(i)

transfArr(i) = _

Array( _

revisionObj.Author, _

revisionObj.Creator, _

revisionObj.Date, _

revisionObj.Type, _

revisionObj.Range.Information(wdActiveEndPageNumber), _

revisionObj.Range.Text, _

"Правка" _

)

Next i

For i = 1 To ActiveDocument.Comments.Count

Set commentObj = ActiveDocument.Comments.Item(i)

transfArr(ActiveDocument.revisions.Count + i) = _

Array( _

commentObj.Author, _

commentObj.Creator, _

commentObj.Date, "", _

commentObj.Scope.Information(wdActiveEndPageNumber), _

commentObj.Range.Text, _

"Примечание" _

)

Next i

Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True

Set xlWs = xlApp.Workbooks.Add

For i = LBound(transfArr, 1) To UBound(transfArr, 1)

For j = LBound(transfArr(i), 1) To UBound(transfArr(i), 1)

xlWs.ActiveSheet.Cells(i + 1, j + 1) = transfArr(i)(j)

Next j

Next i

End Sub