Extract words with red color

[YasserKhalil]

Hello everyone
I have a UDF that enables me to extract only the letters with red color

Code: Select all

Function udf_Whats_Colored(rTXT As Range, Optional iCLRNDX As Long = 3)
    Dim c As Long, str As String

    For c = 1 To Len(rTXT.Text)
        With rTXT.Characters(Start:=c, Length:=1)
            If .Font.ColorIndex = iCLRNDX Then
                If Not CBool(Len(str)) Or _
                   rTXT.Characters(Start:=c + (c > 1), Length:=1).Font.ColorIndex = iCLRNDX Then
                    str = str & Mid(rTXT.Text, c, 1)
                Else
                    str = str & ", " & Mid(rTXT.Text, c, 1)
                End If
            End If
        End With
    Next c
    udf_Whats_Colored = str

End Function

In my new case, I need to extract the whole word even if it has only one red character
Example:
This is an example of sentence that has red characters

The output would be sentence, red

[HansV]

For eaxample:

Code: Select all

Function udf_Whats_Colored(rTXT As Range, Optional iCLRNDX As Long = 3)
    Dim s   As String
    Dim c0  As Long
    Dim c   As Long
    Dim ret As String
    Dim f   As Boolean
    c0 = 1
    f = False
    For c = 1 To rTXT.Characters.Count
        If rTXT.Characters(Start:=c, Length:=1).Text = " " Then
            If f Then
                ret = ret & ", " & rTXT.Characters(Start:=c0, Length:=c - c0).Text
            End If
            f = False
            c0 = c + 1
        ElseIf rTXT.Characters(Start:=c, Length:=1).Font.ColorIndex = iCLRNDX Then
            f = True
        End If
    Next c
    If f Then
        ret = ret & ", " & rTXT.Characters(Start:=c0, Length:=c - c0).Text
    End If
    If ret <> "" Then
        ret = Mid(ret, 3)
    End If
    udf_Whats_Colored = ret
End Function

[YasserKhalil]

Thank you very much
I have tried to test the UDF

Code: Select all

Sub Test()
    Dim r As Long
    Application.ScreenUpdating = False
    For r = 2 To 5
        Cells(r, 2).Value = udf_Whats_Colored(Cells(r, 1))
    Next r
    Application.ScreenUpdating = True
End Sub

But I got an error (Unable to get Count property of the characters class) at this line

Code: Select all

For c = 1 To rTXT.Characters.Count

[HansV]

It works for me. Could you attach a sample workbook that demonstrates the error?

[YasserKhalil]

I have found the cause of error. Some cells have only numeric single value and this caused the error. I have been able to fix that point.
The code works now but for 300 rows, the code takes too ling time

[HansV]

Since we have to check the color of the text, we must loop through the characters, and that is slow.