每次代码发现该单词时，它会将起始位置和结束位置之间的文本复制并粘贴到另一个工作表上，然后滚动到下一个提取，直到它到达原始书写摘录的末尾。
例子是
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
期望的结果是找到所有提取词（苏珊，雅各布斯，彼得）并从'＃34;开始＆＃34;到＆＃34;结束＆＃34;就像在代码中一样，将它们粘贴在一个新的工作簿中。由于我不想在我的名字列表中使用他，所以John不会被包括在内。
代码区分大小写，有人可以帮我创建这个列表函数，我的尝试在下面是NameToHighlight = Array（＆＃34; JASON＆＃34;，＆＃34; JAMES＆＃34;），但是代码只返回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
答案 0 :(得分：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