Question

下面的代码在文档中查找关键字，复制找到关键字的句子，并将其放入Excel文档中。

我想知道是否可以修改此代码以同时搜索多个关键字，并将每个关键字放在同一电子表格中的单独列（或工作表）中。

因此，例如，如果我同时搜索了5个关键字，它会在第1列放置关键字1输出，在第2列放置关键字2输出，在第3列放置关键字3输出，依此类推。

Sub FindWordCopySentence()
    Dim appExcel As Object
    Dim objSheet As Object
    Dim aRange As Range
    Dim intRowCount As Integer
    intRowCount = 1
    Set aRange = ActiveDocument.Range
    With aRange.Find
        Do
            .Text = "Hair"
            .Execute
            If .Found Then
                aRange.Expand Unit:=wdSentence
                myTempText = aRange.Text
                aRange.Collapse wdCollapseEnd
                If objSheet Is Nothing Then
                    Set appExcel = CreateObject("Excel.Application")
                                         Set objSheet = appExcel.workbooks.Open("C:\Users\HNR\Desktop\hair.xlsx").Sheets("Sheet1")
                    intRowCount = 1
                End If
                objSheet.Cells(intRowCount, 1).Value = myTempText
                intRowCount = intRowCount + 1
            End If
        Loop While .Found
    End With
    If Not objSheet Is Nothing Then
        appExcel.workbooks(1).Close True
        appExcel.Quit
        Set objSheet = Nothing
        Set appExcel = Nothing
    End If
    Set aRange = Nothing
End Sub

Answer 1

您可以将大部分代码放在一个循环中，该循环遍历您要搜索的所有值：

Sub FindWordCopySentence()
    Dim appExcel As Object
    Dim objSheet As Object
    Dim aRange As Range
    Dim intRowCount As Integer
    Dim myTempText As String
    Dim findObjects() As Variant
    Dim findIndex As Integer
    'Create array of items to search for
    findObjects = Array("Hair", "something", "else", "to", "search", "for")
    'Loop across each item in the array
    For findIndex = LBound(findObjects) To UBound(findObjects)
        intRowCount = 1
        Set aRange = ActiveDocument.Range
        With aRange.Find
            Do
                'Search for current search term
                .Text = findObjects(findIndex)
                .Execute
                If .Found Then
                    aRange.Expand Unit:=wdSentence
                    myTempText = aRange.Text
                    aRange.Collapse wdCollapseEnd
                    If objSheet Is Nothing Then
                        Set appExcel = CreateObject("Excel.Application")
                        Set objSheet = appExcel.workbooks.Open("C:\Users\HNR\Desktop\hair.xlsx").Sheets("Sheet1")
                        intRowCount = 1
                    End If
                    'Write output to column based on which position of array we are processing
                    objSheet.Cells(intRowCount, findIndex + 1 - LBound(findObjects)).Value = myTempText
                    intRowCount = intRowCount + 1
                End If
            Loop While .Found
        End With
    Next
    If Not objSheet Is Nothing Then
        appExcel.workbooks(1).Close True
        appExcel.Quit
        Set objSheet = Nothing
        Set appExcel = Nothing
    End If
    Set aRange = Nothing
End Sub

修改现有关键字代码以包含多个搜索

1 个答案: