Получение текста из Word в Excel с помощью VBA. Из word в excel vba


Решение: Импорт определенных строк из таблицы Word в Excel

Имеется документ Word с таблицей данных. Необходимо строки, в которых присутствует определенное слово перенести в книгу Excel (все это формируется через макросы в Excel). Поиск слова должен проходить по определенному столбцу таблицы. Нашел макрос, который все данные переносит из Word в Excel. Не осиливаю формирование функционала отбора

Код к задаче: «Импорт определенных строк из таблицы Word в Excel - VBA»

textual Sub Ex_Word_Копирование_по_слову_2()     Dim WA As Object, WD As Object     Dim XA As Object, XD As Object     Dim i&, j&, k&, n&, MyPath$, T$     Set WA = CreateObject("Word.Application")     WA.Visible = True     Set WD = WA.Documents.Open("C:\Temp_Example\Пример_таблиц_для_поиска.docx")     MyPath = WD.Path & "\"     Set XA = CreateObject("Excel.Application") ' Если мы запускаем из Excel - XA лишнее    XA.Visible = True     Set XD = XA.Workbooks.Add     For j = 1 To WD.Tables.Count         For i = 1 To WD.Tables(j).Rows.Count             If InStr(1, WD.Tables(j).cell(i, 1).Range.Text, "FTAS", vbTextCompare) > 0 Then                n = n + 1                '----------------               For k = 1 To WD.Tables(j).Columns.Count                     ' так - вместе с символом конца ячейки:                    'XD.Worksheets(1).Cells(n, k) = WD.Tables(j).cell(i, k).Range.Text                    ' так - без:                    T = WD.Tables(j).cell(i, k).Range.Text                     T = Left(T, Len(T) - 1)                     XD.Worksheets(1).Cells(n, k) = T                Next                '----  или вместо цикла прямое копирование  ----               ' WD.Tables(j).Rows(i).Select               ' Word.Selection.Copy               ''с форматом:               'XD.Worksheets(1).Paste Destination:=XD.Worksheets(1).Cells(n, 1)               ''' без формата:               ''' XD.Worksheets(1).Activate               ''' XD.Worksheets(1).Cells(n, 1).Select               ''' XA.ActiveSheet.PasteSpecial Format:="Текст", Link:=False, DisplayAsIcon:=False               '-----------------------------------            End If         Next     Next     '... End Sub

studassistent.ru

Решение: Перенести данные из Word в Excel

Доброго времени суток. Помогите решить одну задачку для отечественного здравоохранения. Пропихнули сверху в больницу одну тупую программку, разработчики очень туго идут на контакт но при том закрыли исходные коды. Еле добился чтоб создали там один журнал, но формируется он в непотребном виде (списком параметров, 3 пациента на лист, а бумагу экономить надо, приказ глав врача. Написал простенький макрос в WORD приводящий эти данные в потребный вид, что позволяет ручным методом скопировать в EXCEL и получить нормальную таблицу. Но с этим будут работать бабушки с компьютером на вы и с шаловливыми ручками, хотелось бы оптимизировать работу макроса дабы исключить постоянное вмешательства неведомого "оно само, я ничего не делала".Сам алгоритм нынешнего состояния этого дела:1. Формируется журнал в этой программе (веб страничка) 2. Выделяем всё( хорошо что выделяется лишь нужный фрейм), копируем 3. Открываем WORD 4. Выполняем мой макрос (по кнопке на ленте) который:а) вставляет из буфера данные как текст(чтоб лишняя мишура HTML не подцепилась) б) приводит данные в вид (табуляция и абзацы): данные →данные →данные →данные ¶ данные →данные →данные →данные ¶ данные →данные →данные →данные ¶ в) выделяет всё, копирует в буфер обмена5. Открываем EXCEL, создаем новый документ по шаблону, с проставленными типами данных в столбцах, заголовком и параметрами листа для печати (14 столбцов, 1,4-5,7-10,12-14 текстовые, 3 время, остальные даты и рандомное количество строк) 6. Вставляем скопированные данные (специальной вставкой, используя конечное форматирование иначе некоторые данные отображаются некорректно, например нули спереди в числах затираются или чтото отображается как дата) 7. Сохраняем EXCEL таблицу (скорее всего нужно будет сохранять именем файла: нынешняя дата -1 день) и печатаем если надо) 8. Закрываем WORD без сохраненияЧто нужно: После пункта 4 запустить новый макрос, или объединить их... Который делает все последующие шаги на автомате. Макрос должен запускаться из WORD, будет спользоваться MS Office 2010-2013. И думаю если реализовать этот импорт то пункт в) макроса будет ненужен. Список шагов был подлиннее, пока писал это, пришла ещё пара идей как реализовать и запихнул их в макрос PS: Буду рад любым советам и идеям по решению проблемы, даже не касаемым VBA.

studassistent.ru

Решение: Данные из Word в Excel

Здравствуйте! В экселе не силен, поэтому обращаюсь к спецам. Проблема такая, нужно выдернуть данные из таблиц Word: Кадастровый номер, ФИО собственника, Адрес регистрации собственника, Размер доли и вставить эти данные в Еxcel в соответствующие поля. Причем, каждый кадастровый номер - на отдельном листе и название листа по кадастровому номеру.

textual Sub Kadastr()     Dim b(), i&, j&, txt$, oExcel As Object, oXLS As Object     a = Array("Кадастровый (илиусловный) номер объекта:", _         "Правообладатель (правообладатели):", _         "Адрес постоянного места жительства:", _         "право общей долевой собственности:")     txt = ActiveDocument.Range.Text     Set oExcel = CreateObject("Excel.Application")     Set oXLS = oExcel.Workbooks.Add     s = Split(txt, a(0))     For j = 1 To UBound(s)         NumKadastr = Split(s(j), Chr(7))(1)         sf = Split(s(j), a(1))         ReDim b(1 To UBound(sf), 1 To 4)         n = 1         For i = 1 To UBound(sf)             b(i, 1) = n             sf(i) = Replace(sf(i), Chr(13), "")             sa = Split(sf(i), Chr(7))             b(i, 2) = Split(sa(2), ",")(0)             If InStr(sa(2), a(2)) <> 0 Then b(i, 3) = Split(sa(2), a(2))(1)             For k = 3 To UBound(sa)                 If InStr(sa(k), a(3)) <> 0 Then                     b(i, 4) = Split(sa(k), ":")(1)                     Exit For                 End If             Next             n = n + 1         Next         With oXLS.sheets.Add             .Name = Replace(NumKadastr, ":", "-")             .Cells(1, 1) = "Земельный участок №" & NumKadastr             .Cells(1, 1).Font.Size = 20             .Cells(2, 1).Resize(1, 4) = Array("№ п/п", "Ф.И.О", "Адрес регистрации", "Размер доли")             .Cells(3, 1).Resize(UBound(b, 1), UBound(b, 2)) = b             For i = 2 To 4: .Columns(i).ColumnWidth = 35: Next             With .Cells(2, 1).Resize(UBound(b, 1) + 1, 4)                 .Borders.LineStyle = 1                 .BorderAround 1, -4138                 .VerticalAlignment = -4160                 .WrapText = True             End With         End With     Next     oExcel.Visible = True End Sub

studassistent.ru

vba - Получение текста из Word в Excel с помощью VBA

Пока у меня есть близкий к рабочему коду, который анализирует документ и получает заголовок, заголовок и текст между двумя заголовками. Содержимое, которое я пытаюсь извлечь, имеет пули, разрыв строки и т.д., И я хотел бы поддерживать формат, когда я вставляю его в ячейку. Осмотрите и прочитайте много форумов, но не можете понять, как сохранить форматирование неповрежденным. Я заглянул в PasteSpecial, но это вставляет содержимое через несколько ячеек, и я хотел бы избежать копирования/вставки, если это возможно.

Ниже очень раннего кода у меня есть (есть ошибки, которые я отлаживаю/исправляю):

Sub GetTextFromWord() Dim Paragraph As Object, WordApp As Object, WordDoc As Object Dim para As Object Dim paraText As String Dim outlineLevel As Integer Dim title As String Dim body As String Dim myRange As Object Dim documentText As String Dim startPos As Long Dim stopPos As Long Dim file As String Dim i As Long Dim category As String startPos = -1 i = 2 Application.ScreenUpdating = True Application.DisplayAlerts = False file = "C:\Sample.doc" Set WordApp = CreateObject("Word.Application") WordApp.Visible = True Set WordDoc = WordApp.Documents.Open(file) Set myRange = WordDoc.Range documentText = myRange.Text For Each para In ActiveDocument.Paragraphs ' Get the current outline level. outlineLevel = para.outlineLevel ' Cateogry/Header begins outline level 1, and ends at the next outline level 1. If outlineLevel = wdOutlineLevel1 Then 'e.g., 1 Header category = para.Range.Text End If ' Set category as value for cells in Column A Application.ActiveWorkbook.Worksheets("Sheet1").Cells(i - 1, 1).Value = category ' Title begins outline level 1, and ends at the next outline level 1. If outlineLevel = wdOutlineLevel2 Then ' e.g., 1.1 ' Get the title and update cells in Column B title = para.Range.Text Application.ActiveWorkbook.Worksheets("Sheet1").Cells(i, 2).Value = title startPos = InStr(nextPosition, documentText, title, vbTextCompare) If startPos <> stopPos Then ' this is text between the two titles body = Mid$(documentText, startPos, stopPos) ActiveSheet.Cells(i - 1, 3).Value = body End If stopPos = startPos i = i + 1 End If Next para WordDoc.Close WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing End Sub

Ссылка на образец документа

источник поделиться

qaru.site