Копирование части текста из документа Word в ячейку рабочего листа с помощью кода VBA Excel. Поиск по ключевым словам, копирование по абзацам.
Условие задачи
Есть открытый документ Word с именем «Документ1.docx» следующего содержания:
Документ со списком птиц, из которого необходимо извлечь список.
Начало списка
Аист
Буревестник
Воробей
Голубь
Дятел
Жаворонок
Стриж
Конец списка
Для начала и окончания отбора нужных строк (абзацев) будем использовать ключевые слова «Начало» и «Конец».
Необходимо из кода VBA Excel подключиться к открытому документу Word, записать в переменную список птиц и вставить его в активную ячейку.
Копирование части текста
Копирование части текста из документа Word, ограниченного строками (абзацами) с ключевыми словами «Начало» и «Конец», в ячейку рабочего листа:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
Sub Primer() Dim myWord As Word.Application, myDoc As Word.Document, myParag As Word.Paragraph Dim myStr As String, myBool As Boolean On Error GoTo Instruk 'Подключаемся к открытому приложению Word Set myWord = GetObject(, "Word.Application") 'Подключаемся к открытому документу Документ1.docx Set myDoc = myWord.Documents("Документ1.docx") For Each myParag In myDoc.Paragraphs 'Выходим из цикла, если дошли до строки со словом "Конец" If InStr(myParag.Range.Text, "Конец") Then Exit For 'Записываем подходящую по условию строку (абзац) в переменную и добавляем символ переноса строки If myBool = True Then myStr = myStr & myParag.Range.Text & vbNewLine 'Находим строку со словом "Начало", чтобы начать запись строк в переменную со следующей итерации цикла If InStr(myParag.Range.Text, "Начало") Then myBool = True Next myParag 'Удаляем непечатаемые символы в начале строки Do While Asc(myStr) < 32 myStr = Mid(myStr, 2) Loop 'Удаляем непечатаемые символы в конце строки Do While Asc(Right(myStr, 1)) < 32 myStr = Left(myStr, Len(myStr) - 1) Loop 'Вставляем строку из переменной в активную ячейку и осуществляем автоподбор высоты и ширины With ActiveCell .Value = myStr .ColumnWidth = 100 .EntireColumn.AutoFit .EntireRow.AutoFit End With Exit Sub 'Сообщение об ошибке Instruk: If Err.Description <> "" Then MsgBox "Произошла ошибка: " & Err.Description End If End Sub |
Результат работы кода VBA Excel:
Параметр ActiveCell.ColumnWidth устанавливается таким, чтобы изначально ширина ячейки получилась больше ширины самой длинной строки в списке, тогда метод ActiveCell.EntireColumn.AutoFit отработает как положено.