Question

最终结果是选择一个起始位置和结束位置，并将所有条件保持在这些条件之间并删除其余条件。

即。从我的摘录中获取peter的所有消息开始：Peter@hello.co.za
结束：结束消息。

在3000条消息池中，将有大约12条不同的消息具有相同的开始和结束。

程序只保留上述开头和条件的12条消息中的第一条，我需要全部12条消息。

Sub FindAndDeleteEverythingElse()
  Dim strFind1 As String, strFind2 As String
  Dim rngDoc As word.Range, rngFind1 As word.Range
  Dim rngFind2 As word.Range
  Dim bFound As Boolean

  strFind1 = "You"
  strFind2 = "directly."
  Set rngDoc = ActiveDocument.content
  Set rngFind1 = rngDoc.Duplicate
  Set rngFind2 = rngDoc.Duplicate
  With rngFind1.Find
    .Text = strFind1
    bFound = .Execute
  End With
  If bFound Then
    With rngFind2.Find
        .Text = strFind2
        bFound = .Execute
    End With
    If bFound Then
        rngDoc.End = rngFind1.Start
        rngDoc.Delete
        rngDoc.Start = rngFind2.End
        rngDoc.End = ActiveDocument.content.End
        rngDoc.Delete
    End If
  End If
End Sub

Answer 1

使用Cindy提到的帖子中的代码，只需添加几行。

然而，这将失去原始数据集的格式。或者，您可以打开一个新的Word文档，然后复制并遍历数据以保留格式。

 Sub SomeSub1()

 Dim StartWord As String, EndWord As String
 Dim Find1stRange As Range, FindEndRange As Range
 Dim DelRange As Range, DelStartRange As Range, DelEndRange As Range


 Application.ScreenUpdating = True
 Application.DisplayAlerts = True

 Application.ScreenUpdating = False
 'Application.DisplayAlerts = False
 'Setting up the Ranges
 Set Find1stRange = ActiveDocument.Range
 Set FindEndRange = ActiveDocument.Range
 Set DelRange = ActiveDocument.Range

 'Set your Start and End Find words here to cleanup the script
 StartWord = "From: Yussuf Ismail"
 EndWord = "Kind regards"



 '=======================================================================
 '=======================================================================
 'New Code
 'Setting up the array

 Dim MessageNum As Long
 MessageNum = 1
 'can change 100 to whatever you want depending on how many emails you are expecting to find, 100 will cater for 100 obviously
 Dim Emails(100) As Variant  
 '=======================================================================
 '=======================================================================



 'Starting the Find First Word
 With Find1stRange.Find
     .Text = StartWord
     .Replacement.Text = ""
     .Forward = True
     .Wrap = wdFindStop
     .Format = False
     .MatchCase = False
     .MatchWholeWord = False
     .MatchWildcards = False
     .MatchSoundsLike = False
     .MatchAllWordForms = False

     'Execute the Find
     Do While .Execute
         'If Found then do extra script
         If .Found = True Then
             'Setting the Found range to the DelStartRange
             Set DelStartRange = Find1stRange
             'Having these Selections during testing is benificial to test your script
             DelStartRange.Select

             'Setting the FindEndRange up for the remainder of the document form the end of the StartWord
             FindEndRange.Start = DelStartRange.End
             FindEndRange.End = ActiveDocument.Content.End

             'Having these Selections during testing is benificial to test your script
             FindEndRange.Select


             'Setting the Find to look for the End Word
             With FindEndRange.Find
                 .Text = EndWord
                 .Execute

                 'If Found then do extra script
                 If .Found = True Then
                     'Setting the Found range to the DelEndRange
                     Set DelEndRange = FindEndRange

                     'Having these Selections during testing is benificial to test your script
                     DelEndRange.Select

                 End If

             End With

             'Selecting the delete range
             DelRange.Start = DelStartRange.Start
             DelRange.End = DelEndRange.End
             'Having these Selections during testing is benificial to test your script


             '=======================================================================
             '=======================================================================
             'New Code
             'Adding the foudn text into an array
             Emails(MessageNum) = DelRange
             MessageNum = MessageNum + 1
             '=======================================================================
             '=======================================================================



             DelRange.HighlightColorIndex = wdPink
             'Remove comment to actually delete

         End If      'Ending the If Find1stRange .Found = True
     Loop        'Ending the Do While .Execute Loop
 End With    'Ending the Find1stRange.Find With Statement



 '=======================================================================
 '=======================================================================
 'New Code
 ActiveDocument.Content.Delete
 Dim EmailsArrayPosition As Long

 For EmailsArrayPosition = 1 To (MessageNum - 1)  ' -1 to cater for the final increment

      ActiveDocument.Content.InsertAfter Emails(EmailsArrayPosition) & vbNewLine & vbNewLine

 Next EmailsArrayPosition
 '=======================================================================
 '=======================================================================


 End Sub

搜索带循环的消息

1 个答案: