Уважаемые друзья - нужна Ваша помощь в решение одной нетривиальной задачки.
Суть такова : Есть документ Word в нём около 200 листов . Мне необходимо сделать следующее : 1. Открыть документ 2. Найти 10 - 14 строчку на каждой из 200-т страниц 3. Скопировать имеющееся там значение и перенести в столбец А листа БА4 книги Excel
Не знаю , возможно-ли такое в принципе ? Но если возможно Очень прошу помогите.
А если поступить по другому . Весь документ состоит из однотипных листов и необходимый кусок текста всегда находится между одними и теми-же словами это ОТПРАВИТЬ и (ОБЛАСТЬ . Нашел скрипт для этого дела . Однако он почему-то выдает ошибку. Подскажите пожалуйста в чем причина ?
Код
Sub Find()
Dim FSO, fld, f
Dim N, K, Ns, Ks, RN As Range, RX As Range
Dim DC As Word.Document
Ns = "отправить"
Ks = "(область"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.getFolder(ActiveDocument.Path)
ChangeFileOpenDirectory ActiveDocument.Path
For Each f In fld.Files
If InStr(1, f, ActiveDocument.Name) = 0 Then
Set DC = Documents.Open(f.Name)
Set RN = DC.Range
RN.Find.ClearFormatting
RN.Find.Text = Ns
RN.Find.Execute
N = RN.End + 2
Set RN = DC.Range
RN.Find.ClearFormatting
RN.Find.Text = Ks
RN.Find.Execute
K = RN.Start - 1
Set RX = DC.Range(N, K)
MsgBox RX.Text
DC.Close
End If
Next
End Sub
Sub Find2()
Dim N, K, Ns, Ks, RN As Range, RX As Range
Dim DC As Word.Document
Dim a
Dim i
Ns = "Отправить"
Ks = "Область"
Dim objApp As Object
Dim objDoc As Object
Set objApp = CreateObject("Excel.Application")
Set objDoc = objApp.Workbooks.Add
objApp.Visible = True
Set DC = ActiveDocument
With DC
a = .Range.Information(wdNumberOfPagesInDocument)
For i = 1 To a
Set RN = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=i)
RN.Find.ClearFormatting
RN.Find.Text = Ns
RN.Find.Execute
N = RN.End + 1
Set RN = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=i)
RN.Find.ClearFormatting
RN.Find.Text = Ks
RN.Find.Execute
K = RN.Start - 1
If K > N + 9 Then
Set RX = DC.Range(N, K)
objDoc.Sheets(1).Range("A" & i) = DC.Range(N, K)
End If
Next
End With
End Sub
Sub Find2()
Dim N, K, Ns, Ks, RN As Range, RX As Range
Dim DC As Word.Document
Dim a, i, j, sch As Integer
Dim arr()
Dim arr2()
arr = Array("Отправить", "Начало1", "Начало2") 'Замените на свои значения
arr2 = Array("Область", "Конец1", "Конец2") 'Замените на свои значения
Dim objApp As Object
Dim objDoc As Object
Set objApp = CreateObject("Excel.Application")
Set objDoc = objApp.Workbooks.Add
objApp.Visible = True
sch = 1
Set DC = ActiveDocument
With DC
a = .Range.Information(wdNumberOfPagesInDocument)
For i = 1 To a
For j = LBound(arr) To UBound(arr)
Set RN = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=i)
RN.Find.ClearFormatting
RN.Find.Text = arr(j)
RN.Find.Execute
N = RN.End + 1
Set RN = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=i)
RN.Find.ClearFormatting
RN.Find.Text = arr2(j)
RN.Find.Execute
K = RN.Start - 1
If K > N + 6 Then
objDoc.Sheets(1).Range("A" & sch) = DC.Range(N, K)
sch = sch + 1
End If
Next j
Next
End With
End Sub
Не знаю есть ли необходимость создавать новую тему , или продолжать здесь . По сути тема та же.
Подскажите пожалуйста как мне реализовать такую идею :
Есть документ Word в нем 200 страниц. Все страницы однотипные Есть текст есть таблица (документ прилагаю) .
Что мне нужно: (в идеале) На каждом из листов скопировать информацию 1. Место жительства (начинается после слова адрес) и данные из таблицы (могут разнится в основном до 9-ти строк) 2. Поместить скопированую информацию в ячейки Excel (пример таблицы в файле Excel)
Хотелось бы узнать как это сделать программно собственно как вытащить таблицы я нашёл . Однако к каждой таблице привязан адрес (а он вне таблицы) поэтому нужно совместить и записать в ячейки одной строки (Но как это сделать , знаний не хватает)
Вот код который вытаскивает все таблицы в документе
Код
Sub CopyTablesToNewDoc()
Dim docOld As Document
Dim rngDoc As Range
Dim tblDoc As Table
If ActiveDocument.Tables.Count >= 1 Then
Set docOld = ActiveDocument
Set rngDoc = Documents.Add.Range(Start:=0, End:=0)
For Each tblDoc In docOld.Tables
tblDoc.Range.Copy
With rngDoc
.Paste
.Collapse Direction:=wdCollapseEnd
.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
End With
Next
End If
End Sub
axill_3d, можно разделить эту задачу на две в ворде будет макрос для копирования и переноса в эксель а в экселе уже можно сделать макрос для причёсывания. Нужные для переноса в отдельный столбец сведения будут всегда расположены над одной и той же ячейкой - первая ячейка старой "шапки". если же нужен именно один макрос, то лучше делать всё из эксель.
Но "ручками" удобнее - перенёс в эксель, поменял первую строку со второй, первая строка будет шапкой для всей таблицы, остальные шапки удалить.
вам нужно предложить свой код VBA Excel в той части, в которой вы можете его реализовать - например по дальнейшей обработке данных в эксель, нахождению данных для переноса в отдельный столбец. вам уже подскажут по поводу доступа к объектной модели Word. Если не получается что-то конкретное, то также подскажут. То есть не подходите к задаче глобально, попробуйте "по кирпичикам" если же нужны не подсказки, а сделать за вас - то для этого есть платный раздел.
axill_3d, вот вам пример обращения к таблице Word из моего макроса по оформлению сопроводиловки:
Скрытый текст
Код
'
...
'Шаг 5: Открываем шаблон сопроводительного письма и устанавливаем фокус на целевую закладку
'
Set wd = New Word.Application
Set wdDoc = wd.Documents.Open(way & tname)
wd.Visible = True
Set WdRange = wdDoc.Bookmarks("DataTableHere").Range
'
'Шаг 6: Удаляем старую таблицу и вставляем новую
'
On Error Resume Next
WdRange.Tables(1).Delete
WdRange.Paste
'
'Шаг 7: применяем к таблице нужный стиль таблицы, определяем ширину столбцов и высоту строк
'
WdRange.Tables(1).Style = "сопр-табл"
WdRange.Columns(1).Width = "21"
...