在word中找到文本塊中的多個名字，然後複製文本塊

Question

每次代碼發現該單詞時，它都會將開始和結束位置之間的文本複製並粘貼到另一個表單上，並滾動到下一個提取單元，直到它到達原始書面摘錄的結尾。

例子是

Start 
Susan Had a lovely day today and made a lekker poo 
end 

Start1 
John was feeling siiiccckkk so he took a poo too 
end1 

start2 
Peter was in lots of trouble, so he bailed bro 
end2 

start3 
Jacobus rektus van nel het n bal wat hy hey spiel met sy pieletjie 
ending3 

期望得到的結果是要找到所有提取的話（蘇珊，雅各布斯，彼得），並將它們從「開始」到「結束」複製爲代碼和粘貼他們在一本新的工作簿中一個在另一個之下。因此，約翰不會被列入，因爲我不想在名單中使用他。

代碼是區分大小寫的，有人可以幫我創建這個列表函數，我的嘗試在下面用NameToHighlight = Array（「JASON」，「JAMES」），但代碼只返回Jason提取。

Sub CopyMsg_JarrydWard() 
    Dim DocA As Document 
    Dim DocB As Document 
    Dim para As Paragraph 
    Set DocA = ThisDocument 
    Set DocB = Documents.Add 

    Dim Rg As Range, RgMsg As Range 
    Dim StartWord As String, EndWord As String, NameToHighlight As Variant 
    Dim FoundName As Boolean 
    Set Rg = DocA.Content 
    Rg.Find.ClearFormatting 
    Rg.Find.Replacement.ClearFormatting 

    StartWord = "Start Message" 
    EndWord = "End Message" 
    'NameToHighlight = "DUNCAN HOWES" 
'NameToHighlight = "DUNCAN HOWES,cat,pig,horse,man" 
NameToHighlight = Array("JASON", "JAMES ") ' list of words in here 

For i = LBound(NameToHighlight) To UBound(NameToHighlight) 
    With Rg.Find 
     'Set the parameters for your Find method 
     .Text = StartWord & "*" & EndWord 
     .Forward = True 
     .Wrap = wdFindStop 
     .Format = False 
     .MatchCase = False 
     .MatchWholeWord = False 
     .MatchWildcards = True 
     .MatchSoundsLike = False 
     .MatchAllWordForms = False 
     'Execute the Find 
     .Execute 
     'Loop through the results 
     While .Found 
      'Boolean to copy only message containing NameToHighlight 
      FoundName = False 
      'Keep Rg (result range for whole message) intact for later copy 
      Set RgMsg = Rg.Duplicate 

      'Highlight 
      'Start and End 
      DocA.Range(Start:=Rg.Start, End:=Rg.Start + Len(StartWord)).Bold = True 
      DocA.Range(Start:=Rg.End - Len(EndWord), End:=Rg.End).Bold = True 
      'NameToHighlight : here : Susan 
      With RgMsg.Find 
       'Set the parameters for your Find method 
       .Text = NameToHighlight(i) 
       .Forward = True 
       .Wrap = wdFindStop 
       .Format = False 
       .MatchCase = False 
       .MatchWholeWord = False 
       .MatchWildcards = True 
       .MatchSoundsLike = False 
       .MatchAllWordForms = False 
       'Execute the Find 
       .Execute 
       'Loop through the results 
       While .Found 
        RgMsg.Bold = True 
        FoundName = True 
        'Go to the next result for NameToHighlight 
        .Execute 
       Wend 
      End With 'RgMsg.Find 

      'Copy the whole message if NameToHighlight was found 
      If FoundName Then 
       Rg.Copy 
       DocB.Bookmarks("\EndOfDoc").Range.Text = "Page " & _ 
         Rg.Characters.First.Information(wdActiveEndPageNumber) & vbCr 
       DocB.Bookmarks("\EndOfDoc").Range.Paste 
       DocB.Bookmarks("\EndOfDoc").Range.Text = vbCr & vbCr 
      End If 
      'Go to the next result for the message 
      .Execute 
     Wend 
    End With 'Rg.Find 
    Next i 
End Sub 

Answer 1

你接近，但你需要用的Find只有名稱：

Sub CopyMsg_JarrydWard() 
    Dim DocA As Document 
    Dim DocB As Document 
    Dim para As Paragraph 
    Set DocA = ThisDocument 
    Set DocB = Documents.Add 

    Dim Rg As Range, RgMsg As Range 
    Dim StartWord As String, EndWord As String, NameToHighlight As Variant 
    Dim FoundName As Boolean 
    Set Rg = DocA.Content 
    Rg.Find.ClearFormatting 
    Rg.Find.Replacement.ClearFormatting 

    StartWord = "Start Message" 
    EndWord = "End Message" 
    'NameToHighlight = "DUNCAN HOWES" 
'NameToHighlight = "DUNCAN HOWES,cat,pig,horse,man" 
NameToHighlight = Array("JASON", "JAMES ") ' list of words in here 

    With Rg.Find 
     'Set the parameters for your Find method 
     .Text = StartWord & "*" & EndWord 
     .Forward = True 
     .Wrap = wdFindStop 
     .Format = False 
     .MatchCase = False 
     .MatchWholeWord = False 
     .MatchWildcards = True 
     .MatchSoundsLike = False 
     .MatchAllWordForms = False 
     'Execute the Find 
     .Execute 
     'Loop through the results 
     While .Found 
      'Boolean to copy only message containing NameToHighlight 
      FoundName = False 
      'Keep Rg (result range for whole message) intact for later copy 
      Set RgMsg = Rg.Duplicate 

      'Highlight 
      'Start and End 
      DocA.Range(Start:=Rg.Start, End:=Rg.Start + Len(StartWord)).Bold = True 
      DocA.Range(Start:=Rg.End - Len(EndWord), End:=Rg.End).Bold = True 

      For i = LBound(NameToHighlight) To UBound(NameToHighlight) 
       'NameToHighlight : here : Susan 
       With RgMsg.Find 
        'Set the parameters for your Find method 
        .Text = NameToHighlight(i) 
        .Forward = True 
        .Wrap = wdFindStop 
        .Format = False 
        .MatchCase = False 
        .MatchWholeWord = False 
        .MatchWildcards = True 
        .MatchSoundsLike = False 
        .MatchAllWordForms = False 
        'Execute the Find 
        .Execute 
        'Loop through the results 
        While .Found 
         RgMsg.Bold = True 
         FoundName = True 
         'Go to the next result for NameToHighlight 
         .Execute 
        Wend 
       End With 'RgMsg.Find 
      Next i 
      'Copy the whole message if NameToHighlight was found 
      If FoundName Then 
       Rg.Copy 
       DocB.Bookmarks("\EndOfDoc").Range.Text = "Page " & _ 
         Rg.Characters.First.Information(wdActiveEndPageNumber) & vbCr 
       DocB.Bookmarks("\EndOfDoc").Range.Paste 
       DocB.Bookmarks("\EndOfDoc").Range.Text = vbCr & vbCr 
      End If 
      'Go to the next result for the message 
      .Execute 
     Wend 
    End With 'Rg.Find 
End Sub