Страницы: 1
RSS
Собрать в таблицу Excel сведения из таблиц Word файла
 
Добрый день.
Имеются сведения в Word файле, в таблице (см. скрин)
Таких таблиц в word-файле несколько, каждый на отдельной странице.
Их нужно собрать в таблицу Excel файла (см. скрин)
Можете помочь с макросом?
Изменено: Бахтиёр - 11.11.2022 10:47:56
 
Вот в такую таблицу excel их нужно собрать (см. скрин)
 
Могу вечером сделать скрипт на питоне
 
aset224, может быть к тому времени кто-то поможет
 
Бахтиёр, вот кусочек примера деревянного (не умею писать макросы) без первых 2-ух столбцов. - не табличные.
Явно одной строкой можно это забрать а не 7-ю, кто-то поправит из умеющих - может и я запомню.
P.S: Закидываю пока не понимаю как 40 подряд идущих столбцов в Autocad по одной пока )
Файл Word  должен лежать в паке с Excel.
Есть баг картинку приложил tmp файл просит разрешить макросы - надо закрыть это окно - иначе ошибка
Код
Sub Таблицы()
Path = ThisWorkbook.Path & Application.PathSeparator & "word форум.docx"
Set wd = CreateObject("Word.Application")
wd.documents.Open Path
wd.Visible = True
n = 1
For i = 1 To wd.activedocument.Tables.Count
DoEvents
n = n + 1
Cells(n, 3).Value = Application.Clean(wd.activedocument.Tables(i).Cell(1, 2).Range.Text)
Cells(n, 4).Value = Application.Clean(wd.activedocument.Tables(i).Cell(2, 2).Range.Text)
Cells(n, 5).Value = Application.Clean(wd.activedocument.Tables(i).Cell(3, 2).Range.Text)
Cells(n, 6).Value = Application.Clean(wd.activedocument.Tables(i).Cell(4, 2).Range.Text)
Cells(n, 7).Value = Application.Clean(wd.activedocument.Tables(i).Cell(5, 2).Range.Text)
Cells(n, 8).Value = Application.Clean(wd.activedocument.Tables(i).Cell(6, 2).Range.Text)
Cells(n, 9).Value = Application.Clean(wd.activedocument.Tables(i).Cell(7, 2).Range.Text)
Next i
wd.documents.Close
wd.Quit
Set wd = Nothing
End Sub
Изменено: Тимофеев - 11.11.2022 14:44:14
 
Спасибо, попробую.
 
Добавил остальное
Файл Word в папке с Excel !!!
Откуда этот файл tmp появляется и как ему разрешить макросы я не разобрался
Код
Sub Таблицы()
Path = ThisWorkbook.Path & Application.PathSeparator & "word форум.docx"
Set wd = CreateObject("Word.Application")
wd.documents.Open Path
wd.Visible = True
n = 1
For i = 1 To wd.activedocument.Tables.Count
DoEvents
n = n + 1
ParagraphNum = wd.activedocument.Tables(i).Range.Start - 1
ParagraphNum = wd.activedocument.Range(Start:=0, End:=ParagraphNum).Paragraphs.Count
Cells(n, 1).Value = Application.Clean(wd.activedocument.Paragraphs(ParagraphNum).Range.Text)
Cells(n, 2).Value = wd.activedocument.Paragraphs(ParagraphNum).Range.ListFormat.ListString
Cells(n, 3).Value = Application.Clean(wd.activedocument.Tables(i).Cell(1, 2).Range.Text)
Cells(n, 4).Value = Application.Clean(wd.activedocument.Tables(i).Cell(2, 2).Range.Text)
Cells(n, 5).Value = Application.Clean(wd.activedocument.Tables(i).Cell(3, 2).Range.Text)
Cells(n, 6).Value = Application.Clean(wd.activedocument.Tables(i).Cell(4, 2).Range.Text)
Cells(n, 7).Value = Application.Clean(wd.activedocument.Tables(i).Cell(5, 2).Range.Text)
Cells(n, 8).Value = Application.Clean(wd.activedocument.Tables(i).Cell(6, 2).Range.Text)
Cells(n, 9).Value = Application.Clean(wd.activedocument.Tables(i).Cell(7, 2).Range.Text)
Next i
wd.documents.Close
wd.Quit
Set wd = Nothing
End Sub
Изменено: Тимофеев - 11.11.2022 18:43:52
 
Тимофеев, спасибо большое, получилось, есть маленькие ньюансы, думаю могу сам подстроить код под себя.
Если будут вопросы, буду обращаться.
 
Cделал код для Word'a:
Код
Sub qwqw()
Dim wd As New Document
Set wd = ActiveDocument
tc = wd.Tables.Count
ReDim mas(1 To tc, 1 To 10)
For i = 1 To tc
    If i > 1 Then
        mas(i, 1) = CleanString(wd.Range(wd.Tables(i - 1).Range.End, wd.Tables(i).Range.Start - 1).Paragraphs.Last.Range)
    Else
        mas(i, 1) = CleanString(wd.Range(0, wd.Tables(1).Range.Start - 1).Paragraphs.Last.Range)
    End If
    For k = 1 To wd.Tables(i).Rows.Count
        mas(i, k + 1) = CleanString(wd.Tables(i).Cell(k, 2).Range)
    Next
Next
Set xl = CreateObject("Excel.Application")
xl.Visible = True
xl.Workbooks.Add.Sheets(1).Cells(1).Resize(tc, 10).Value = mas
Set xl = Nothing
End Sub
Страницы: 1
Наверх