단어의 텍스트 블록 안에 여러 단어를 찾고 텍스트 블록을 복사하십시오.

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 

가 원하는 결과는 모든 코드 및 붙여 넣기에서와 같이 단어 (수잔, 야코 부스, 베드로)와 "시작" "끝"까지 복사하기를 추출 찾을 것이다 것 그 중 하나는 새로운 통합 문서에서 다른 하나보다 아래에 있습니다. 따라서 John은 내 이름 목록에 그를 사용하고 싶지 않았기 때문에 포함되지 않았습니다.

코드는 대소 문자를 구별합니다.이 목록 기능을 생성하는 데 도움을 주시겠습니까? 내 시도는 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