試圖突出顯示兩個詞之間的文字

Question

我有一個我創建的宏幾乎就在那裏。宏的目的是查找某些單詞並突出顯示它們，對話框的格式總是相同的，例如per below：

**=====Begin Message=====** 
Message#: 10 
Message Sent: 08/06/2008 04:48:09 
**Susan:** I there How are you 
Peter: I am great thanks 
**Susan:**lekkkkkeeerrr 
Peter:siiiiccckkkk 
**=====End Message=====** 

=====Begin Message===== 
Message#: 10 
Message Sent: 08/06/2008 04:48:09 
Jack: Hey boyyyss…want to get shit faced 
Peter: I am great thanks, keen to do it 
Jack:lekkkkkeeerrr 
Peter:siiiiccckkkk 
=====End Message===== 

現在宏將做什麼是突出顯示每個文本，說「蘇珊」以及「開始」和「結束消息」。那麼什麼宏將要做的就是打開一個新的Word文檔，並粘貼在包含蘇珊它和期望的結果應如下消息：

**=====Begin Message=====** 
Message#: 10 
Message Sent: 08/06/2008 04:48:09 
**Susan:** I there How are you 
Peter: I am great thanks 
**Susan:**lekkkkkeeerrr 
Peter:siiiiccckkkk 
**=====End Message=====** 

=====信息起始=== ==

=====結束消息=====

不幸的是，宏不這樣做，而是將輸出只有一切蘇珊說並沒有什麼什麼彼得回答她。如象下面這樣：

**=====Begin Message=====** 
Message#: 10 
Message Sent: 08/06/2008 04:48:09 
**Susan:** I there How are you 

**Susan:**lekkkkkeeerrr 

**=====End Message=====** 

    **=====Begin Message=====** 

    **=====End Message=====** 

我突出的原因開始和結束部分是因爲宏膏每端開始被強調了，然後採取環繞蘇珊hihglight所有段落，但還不夠，我想要的一切如果文本突出顯示，則在開始消息和結束消息之間。下面是我的代碼至今：

Sub CopyParagraphs() 
    Dim DocA As Document 
    Dim DocB As Document 
    Dim para As Paragraph 

    Set DocA = ActiveDocument 
    Set DocB = Documents.Add 

    For Each para In DocA.Paragraphs 
     With para.range.Find 
      .Highlight = True ' could try: If para.range.HighlightColorIndex = wdYellow Then etc etc 
      If .Execute() Then 
       para.range.Copy 
       DocB.Bookmarks("\EndOfDoc").range.Text = "Page " & para.range.Characters.First.Information(wdActiveEndPageNumber) & vbCr 
       DocB.Bookmarks("\EndOfDoc").range.Paste 
       DocB.Bookmarks("\EndOfDoc").range.Text = vbCr & vbCr 
      End If 
     End With 
    Next para 
End Sub 

請提前，所有=====開始留言=====，=====結束消息假裝=====和蘇珊的話是突出顯示的，我只是向你展示我擁有的複製段落代碼。

Answer 1

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 String 
    Dim FoundName As Boolean 
    Set Rg = DocA.Content 
    Rg.Find.ClearFormatting 
    Rg.Find.Replacement.ClearFormatting 

    StartWord = "=====Begin Message=====" 
    EndWord = "=====End Message=====" 
    NameToHighlight = "Susan" 

    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 
       .Forward = True 
       .Wrap = wdFindStop 
       .Format = False 
       .MatchCase = False 
       .MatchWholeWord = False 
       .MatchWildcards = False 
       .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 
End Sub