Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Найти и перенести из Word в Excel фрагмент текста, который находится между известными словами
 
#1
30.07.2021 10:47:20
Уважаемые друзья - нужна Ваша помощь в решение одной нетривиальной задачки.

Суть такова :
Есть документ Word в нём около 200 листов . Мне необходимо сделать следующее :
1. Открыть документ
2. Найти 10 - 14 строчку на каждой из 200-т страниц
3. Скопировать имеющееся там значение и перенести в столбец А листа БА4 книги Excel

Не знаю , возможно-ли такое в принципе ?  Но если возможно
Очень прошу помогите.  
Изменено: vikttur - 01.08.2021 08:07:16
 
 
 
#2
30.07.2021 22:47:12
получается, нужно перенести пять целых строк (строки 10-14) с каждой страницы документа Word в каждую ячейку столбца A документа Excel
 
 
 
#3
31.07.2021 20:42:26
А если поступить по другому . Весь документ состоит из однотипных листов и необходимый кусок текста всегда находится между одними и теми-же словами это ОТПРАВИТЬ и (ОБЛАСТЬ . Нашел скрипт для этого дела . Однако он почему-то выдает ошибку. Подскажите пожалуйста в чем причина ?
Код
 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
 
 
 
#4
01.08.2021 06:44:45
Здравствуйте, попробуйте.
Код
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
Вредить легко, помогать трудно.
 
 
 
#5
01.08.2021 15:36:53
nbaengineer, jгромное СПАСИБО !!!!
Всё получилось. ПРОСТО СУПЕР !!!

И ещё вопрос , а если фрагментов несколько ? Можете показать как такой вариат реализовать .  
Изменено: vikttur - 01.08.2021 16:23:16
 
 
 
#6
02.08.2021 06:44:38
Код
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
Изменено: nbaengineer - 02.08.2021 06:51:52
Вредить легко, помогать трудно.
 
 
 
#7
02.08.2021 10:07:58
Ну вот и определились ;)
 
 
 
#8
03.08.2021 11:00:11
nbaengineer,

Спасибо . Только скрипт выводит всё в одну колонку , а есть возможность выводимый текст разбить по колонкам. ?  
 
 
 
#9
04.08.2021 11:39:30
Не знаю есть ли необходимость создавать новую тему , или продолжать здесь . По сути тема та же.

Подскажите пожалуйста как мне реализовать такую идею :

Есть документ Word в нем 200 страниц. Все страницы однотипные  Есть текст есть таблица (документ прилагаю) .

Что мне нужно: (в идеале)
На каждом из листов скопировать информацию
1. Место жительства (начинается после слова адрес) и данные из таблицы (могут разнится в основном до 9-ти строк)
2. Поместить скопированую информацию в ячейки Excel (пример таблицы в файле Excel)
Изменено: vikttur - 04.08.2021 23:56:30
 
 
 
#10
04.08.2021 15:54:59
с помощью регулярных выражений с использованием подстановочных знаков удалить все ненужные абзацы
примерно так:

найти            ЗЕЛЕНОГОРСЬКА*адреса:
заменить на   конецфрагмента    

найти            Довідка*конецфрагмента
заменить на                                               (пусто)

остаются только нужные сведения - копируем их из Word в Эксель
 
 
 
#11
04.08.2021 16:34:51
Цитата
nilske написал:
остаются только нужные сведения - копируем их из Word в Эксель
Там есть таблица , как из неё скопировать информацию ?  
Изменено: axill_3d - 04.08.2021 16:35:17
 
 
 
#12
05.08.2021 10:21:32
axill_3d,  Ctrl+A, Ctrl+C

Ещё - чтобы потом проще было "поичёсывать" в Excel:
в ворде перед копированием заменить каждый знак абзаца на пробел
Изменено: nilske - 05.08.2021 10:48:50
 
 
 
#13
05.08.2021 11:00:52
Цитата
nilske написал:
Ctrl+A, Ctrl+C
:)

Хотелось бы узнать как это сделать программно собственно как вытащить таблицы я нашёл . Однако к каждой таблице привязан адрес (а он вне таблицы) поэтому нужно совместить и записать в ячейки одной строки (Но как это сделать , знаний не хватает)

Вот код который вытаскивает все таблицы в документе
Код
 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
 
 
 
#14
05.08.2021 11:11:55
axill_3d, можно разделить эту задачу на две
в ворде будет макрос для копирования и переноса в эксель
а в экселе уже можно сделать макрос для причёсывания.
Нужные для переноса в отдельный столбец сведения будут всегда расположены над одной и той же ячейкой - первая ячейка старой "шапки".
если же нужен именно один макрос, то лучше делать всё из эксель.

Но "ручками" удобнее - перенёс в эксель, поменял первую строку со второй, первая строка будет шапкой для всей таблицы, остальные шапки удалить.
 
 
 
#15
05.08.2021 11:22:02
Цитата
nilske написал:
если же нужен именно один макрос, то лучше делать всё из эксель.
А как это сделать из эксель ?  Если можна хотя бы пример  Просто очень нужно . Пока не реализую не могу дальше двигаться .
 
 
 
#16
05.08.2021 11:27:10
вам нужно предложить свой код VBA Excel в той части, в которой вы можете его реализовать - например по дальнейшей обработке данных в эксель, нахождению данных для переноса в отдельный столбец.
вам уже подскажут по поводу доступа к объектной модели Word.
Если не получается что-то конкретное, то также подскажут.
То есть не подходите к задаче глобально, попробуйте "по кирпичикам" :)
если же нужны не подсказки, а сделать за вас - то для этого есть платный раздел.
 
 
 
#17
05.08.2021 11:53:39
axill_3d,
вот вам пример обращения к таблице Word из моего макроса по оформлению сопроводиловки:
Скрытый текст
Изменено: nilske - 05.08.2021 12:26:15
 
 
 
Страницы: 1
Наверх