Копировать текст из Word в Excel на основе списка поисковых слов

Question

Здравствуйте, уважаемые участники форума,

в контексте исследовательской работы в моем университете, я должен перенести текстовые отрывки из документов Word в файл Excel на основе ключевых слов.

Это список ключевых слов (все они перечислены ниже друг друга в столбце Excel) и несколько документов Word (около 80–100 с 400 страницами в каждом).

Программа должна искать в документе Word ключевые слова и, если слово найдено, соответствующее слово + 350 символов до и после слова должно быть скопировано в строку Excel. Кроме того, необходимо скопировать название документа и количество страниц. Каждое найденное слово должно быть скопировано в новую строку.

На основании первых исследований в Google я получил следующий код. Большая часть этого уже работает с этим кодом.

Мне нужна ваша помощь по следующим двум пунктам:

1.) Как расширить текст для копирования? Если искомое слово найдено в документе word, слово + 350 символов до и после слова должно быть скопировано.

2.) Как должен выглядеть al oop, чтобы все документы Word в папке обрабатывались один за другим?

Поскольку после долгой попытки я не нашел решения, я рад каждому совету или решению.

Sub LocateSearchItem_Test22()
Dim shtSearchItem As Worksheet
Dim shtExtract As Worksheet
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim LastRow As Long                 
Dim CurrRowShtSearchItem As Long    
Dim CurrRowShtExtract As Long      
Dim myPara As Long
Dim myLine As Long
Dim myPage As Long
Dim oDocName As Variant

    On Error Resume Next

    Application.ScreenUpdating = False

    Set oWord = GetObject(, "Word.Application")

    If Err Then
        Set oWord = New Word.Application
        WordNotOpen = True
    End If

    On Error GoTo Err_Handler

    oWord.Visible = True
    oWord.Activate
    Set oDoc = oWord.Documents.Open("C:\Users\Lenovo\Downloads\Data fronm Word to Excel\Testdatei.docx")       

    oDocName = ActiveDocument.Name

    Set shtSearchItem = ThisWorkbook.Worksheets(1)
    If ThisWorkbook.Worksheets.Count < 2 Then
        ThisWorkbook.Worksheets.Add After:=shtSearchItem
    End If
    Set shtExtract = ThisWorkbook.Worksheets(2)

    LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row

    For CurrRowShtSearchItem = 2 To LastRow
        Set oRange = oDoc.Range
        With oRange.Find
            .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
            .MatchCase = False
            '.MatchWholeWord = False
            .MatchWildcards = True
            While oRange.Find.Execute = True
                oRange.Select
                myPara = oDoc.Range(0, oWord.Selection.Paragraphs(1).Range.End).Paragraphs.Count
                myPage = oWord.Selection.Information(wdActiveEndAdjustedPageNumber)
                myLine = oWord.Selection.Information(wdFirstCharacterLineNumber)

                CurrRowShtExtract = CurrRowShtExtract + 1

                    shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
                    shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
                    shtExtract.Cells(CurrRowShtExtract, 3).Value = myPage
                    shtExtract.Cells(CurrRowShtExtract, 4).Value = myLine
                    shtExtract.Cells(CurrRowShtExtract, 5).Value = oDocName
                    shtExtract.Cells(CurrRowShtExtract, 6) = oDoc.Paragraphs(myPara).Range

                oRange.Collapse wdCollapseEnd

            Wend
        End With
    Next CurrRowShtSearchItem

    If WordNotOpen Then
        oWord.Quit
    End If

    'Release object references

    Set oWord = Nothing
    Set oDoc = Nothing

    Exit Sub

Err_Handler:
    MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
    If WordNotOpen Then
        oWord.Quit
    End If

End Sub

Answer 1

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

Вот ваша находка:

With oRange.Find
    .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
    .MatchCase = False
    '.MatchWholeWord = False
    .MatchWildcards = True 'do you really want wildcards?
    .Wrap = wdFindStop
    While .Execute = True
        myPara = oDoc.Range(0, oRange.End).Paragraphs.Count
        myPage = oRange.Information(wdActiveEndAdjustedPageNumber)
        myLine = oRange.Information(wdFirstCharacterLineNumber)
'Expand range size begins here        
        oRange.MoveStart wdCharacter, -350 'not sure if you want the info of just the word or the word +/- 350 characters
        oRange.MoveEnd wdCharacter, 350

        CurrRowShtExtract = CurrRowShtExtract + 1

                    shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
                    shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
                    shtExtract.Cells(CurrRowShtExtract, 3).Value = myPage
                    shtExtract.Cells(CurrRowShtExtract, 4).Value = myLine
                    shtExtract.Cells(CurrRowShtExtract, 5).Value = oDocName
                    shtExtract.Cells(CurrRowShtExtract, 6) = oRange.Text

                oRange.Collapse wdCollapseEnd
    Wend
End With

Никогда ничего не выбирайте, если можете помочь. Почти все в Word может быть сделано без использования выделения. Объявите диапазон и манипулируйте диапазоном. Там нет необходимости выбирать его.

Что касается циклического просмотра каждого документа в папке, взгляните на FileSystemObject. Документация ужасна, но результаты Google в целом довольно хороши.