Vba 在word中的文本块内查找多个名称并复制该文本块

每次代码发现这个单词时，它都会将文本复制并粘贴到另一张纸上的起始位置和结束位置之间，然后滚动到下一个摘录，直到到达原始书面摘录的结尾

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

例如

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

理想的结果是找到所有的单词摘录（Susan、Jacobus、Peter），并将它们从代码中的“开始”复制到“结束”，然后将它们一个接一个地粘贴到新工作簿中。因此，John不会被包括在内，因为我不想在我的姓名列表中使用他

代码区分大小写，请有人帮我创建这个列表函数，我的尝试如下，名称为nametohlight=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

---

您已经很接近了，但只需要为名称包装

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

---

非常感谢巴德，我确实为早些时候的敌意感到难过……你的代码编写技能非常先进，我非常感谢你的帮助，我希望你有一个超级周末，再次非常感谢。@Jarrydwardward:别担心，只是不要让它再次发生！；）也祝你周末愉快！；）