Find Font Colour or Strikethrough

[Bernadette]

Hello All,

What a great forum! You have been so helpful to me. I have another question. Is it possible to get a macro to find the next occurrence of either red or blue text or strikethrough? I want it to select the next occurrence of either of these attributes.

Thank you!
Bernie

[gmaxey]

Something like this:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Word.Range
Dim oCol As Collection
Dim lngIndex As Long
  Set oCol = New Collection
  For lngIndex = 1 To 3
    Set oRng = ActiveDocument.Range
    oRng.Start = Selection.End
    With oRng.Find
      .Wrap = wdFindStop
      Select Case lngIndex
        Case 1: .Font.Color = wdColorBlue
        Case 2: .Font.Color = wdColorRed
        Case 3: .Font.StrikeThrough = True
      End Select
      If .Execute Then
        If oCol.Count = 0 Then
          oCol.Add oRng
        Else
          If oRng.Start < oCol.Item(1).Start Then
            oCol.Remove 1
            oCol.Add oRng
          End If
        End If
      End If
    End With
  Next
  If oCol.Count > 0 Then
    oCol.Item(1).Select
  End If
lbl_Exit:
  Exit Sub
  
End Sub

[Bernadette]

Awesome! Works perfectly. Thanks so much.

[Bernadette]

The macro is working great unless the red text happens to be in a table. If the macro finds red text in a table it won't go any further. Any suggestions?

[gmaxey]

Sub ScratchMacro()
     'A basic Word macro coded by Greg Maxey
    Dim oRng As Word.Range
    Dim oCol As Collection
    Dim lngIndex As Long
    Set oCol = New Collection
    For lngIndex = 1 To 3
        Set oRng = ActiveDocument.Range
        oRng.Start = Selection.End
        With oRng.Find
            .Wrap = wdFindStop
            Select Case lngIndex
            Case 1: .Font.Color = wdColorBlue
            Case 2: .Font.Color = wdColorRed
            Case 3: .Font.StrikeThrough = True
            End Select
            Do While .Execute
                If oCol.Count = 0 Then
                    If oRng.Start > Selection.End Then
                      oCol.Add oRng
                      Exit Do
                    End If
                Else
                    If oRng.Start < oCol.Item(1).Start Then
                        oCol.Remove 1
                        oCol.Add oRng
                        Exit Do
                    End If
                End If
            Loop
        End With
    Next
    If oCol.Count > 0 Then
        oCol.Item(1).Select
    End If
lbl_Exit:
    Exit Sub
     
End Sub

[Bernadette]

Thank you but it still gets stuck in the table...

[gmaxey]

"The table." What table? It doesn't get stuck in my table.

[Bernadette]

It must be something weird in my document. I tried it in a new document with a table and it worked fine. Thanks again!