修改現有關鍵字代碼以包含多次搜索

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