Find all text formatted with given color

问题:

I am looking for a way to create a new document containing all the text with a specific format from my document.

See below for what I wrote so far, but I'm stuck here:

• how do I stop my loop when end of document is reached? or how do I add intelligence to my code to avoid a static loop, and rather do a "scan all my document"?

---

Option Explicit

Sub Macro1()
   Dim objWord  As Application
   Dim objDoc As Document
   Dim objSelection As Selection

    Dim mArray() As String
    Dim i As Long
    Dim doc As Word.Document

    For i = 1 To 100
      ReDim Preserve mArray(i)
      With Selection.Find
        .ClearFormatting
        .Font.Color = wdColorBlue
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .Execute
      End With

      mArray(i) = Selection.Text

    Next

   Set objWord = CreateObject("Word.Application")
   Set objDoc = objWord.Documents.Add
   objWord.Visible = True
   Set objSelection = objWord.Selection

    For i = 1 To 100
    objSelection.TypeText (mArray(i))
    Next
End Sub

回答1:

Thanks to Cindy's nice tip (I could also have found relevant information in Loop through Word document, starting from beginning of file at start of each loop), and in case this could help someone some day:

1. define the format you are looking for thanks to Word's Macro Recorder

2. position yourself at the beginning of your document

3. Use a while loop checking wdFindStop -- It also demonstrate how to use Array of String in VBA--:

...

Sub Macro2()
    Dim mArray() As String
    Dim i As Long, n As Long
    Dim doc As Word.Document
    Dim isFound As Boolean
    isFound = True
    i = 1
    'For i = 1 To 40
    Do While (isFound)
      ReDim Preserve mArray(i)
      With Selection.Find
        .ClearFormatting
        .Font.Color = wdColorBlue
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        isFound = .Execute
      End With
      mArray(i) = Selection.Text
      i = i + 1
    Loop
    'Next
    n = i - 2
    MsgBox n & " occurrences found."

    '
    ' create a new document with the phrases found

    Dim objWord  As Application
    Dim objDoc As Document
    Dim objSelection As Selection
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    objWord.Visible = True
    Set objSelection = objWord.Selection
    For i = 1 To n 'mArray's Size
      objSelection.TypeText (mArray(i))
      objSelection.TypeParagraph
    Next
End Sub

NB: I could also have greatly benefited from https://msdn.microsoft.com/en-us/library/office/aa211953%28v=office.11%29.aspx that explains how to find without changing the selection:

 With ActiveDocument.Content.Find
  .Text = "blue"
  .Forward = True
  .Execute
  If .Found = True Then .Parent.Bold = True
 End With

And from here: Find text only of style "Heading 1" (Range.Find to match style)