根据搜索词列表将文本从 Word 复制到 Excel

Question

亲爱的论坛成员，您好，

在我大学的研究工作中，我必须根据关键字将文本段落从 Word 文档转移到 Excel 文件中。

这是一个关键字列表（在 Excel 列中逐个列出）和几个 Word 文档（大约 80-100 个，每个 400 页）。

程序应在 Word 文档中搜索关键字，如果找到单词，则应将相应的单词 + 单词前后的 350 个字符复制到 Excel 行。此外，应复制文件的名称和页数。每个找到的单词都应该复制到一个新行中。

根据 Google 的初步研究，我收到了以下代码。其中大部分已经适用于此代码。

以下两点需要您的帮助：

1.) 如何扩展要复制的文本？如果在word文档中找到一个搜索词，则应该复制该词+该词前后350个字符。

2.) 一个循环应该是什么样子，以便一个文件夹中的所有 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

我将特别关注单词部分，因为那是我的专长。看来您对 VBA 了解不少，所以我将使用 sn-ps 来回答。

这是你的发现：

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 的结果通常都不错。