Extract words that have colored characters (even single colored character)-CodePudding

Having UDF that extracts the words in sentences that have any colored character. The code is working but too slow. I tested the code at only 300 rows and it took about 15 minutes to finish

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

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

Is it possible to make it faster or is there another efficient approach to achieve such a task?

CodePudding user response：

Solution
Tested for 500 lines and it takes around 30 seconds for the whole logic without the optimization for code speed up that I commented above (IE: screenupdating = False, should be faster with those)

Sub Test()
Dim CounterRow As Long
    For CounterRow = 2 To 501
    Cells(CounterRow, 2).Value = Return_TxtColored(Cells(CounterRow, 1), IsColorSpecific:=True, NumColorIndexSpecific:=255)
    Cells(CounterRow, 3).Value = Return_TxtColored(Cells(CounterRow, 1), IsColorSpecific:=True, NumColorIndexSpecific:=5296274)
    Cells(CounterRow, 4).Value = Return_TxtColored(Cells(CounterRow, 1), 0)
    Cells(CounterRow, 5).Value = Return_TxtColored(Cells(CounterRow, 1), IsColorSpecific:=True, NumColorIndexSpecific:=255, IsWholeWordNeeded:=True, TxtDelimiter:=" ")
    Cells(CounterRow, 6).Value = Return_TxtColored(Cells(CounterRow, 1), IsColorSpecific:=True, NumColorIndexSpecific:=5296274, IsWholeWordNeeded:=True, TxtDelimiter:=" ")
    Cells(CounterRow, 7).Value = Return_TxtColored(Cells(CounterRow, 1), 0, IsWholeWordNeeded:=True, TxtDelimiter:=" ")
    Next CounterRow
End Sub
Function Return_TxtColored(RangeTxtToAnalyze As Range, Optional NumColorIndexIgnored As Long, Optional IsColorSpecific As Boolean, Optional NumColorIndexSpecific, Optional IsWholeWordNeeded As Boolean, Optional TxtDelimiter As String) As String
'Although optional, you need either TxtRGBColorIgnored or IsColorSpecific & TxtRGBColorSpecific
'If IsWholeWordNeeded then you need to specify the delimiter too
Dim CounterChr As Long
Dim TxtDummy As String
Dim NumSumArrChrs As Long
Dim NumCounterSumArrChrs As Long
Dim ArrTxtToAnalyze() As String
    If IsWholeWordNeeded = True Then ArrTxtToAnalyze = Split(RangeTxtToAnalyze.Value, TxtDelimiter)
    For CounterChr = 1 To RangeTxtToAnalyze.Characters.Count
    If IsColorSpecific = True Then ' 1. If IsColorSpecific = True
    If IsWholeWordNeeded = True Then ' 2. If IsWholeWordNeeded = True
    If RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Font.Color = NumColorIndexSpecific Then ' 1. If RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Font.Color = NumColorIndexSpecific
    NumSumArrChrs = 0: NumCounterSumArrChrs = 0
    Do Until CounterChr <= NumSumArrChrs
    NumSumArrChrs = Len(ArrTxtToAnalyze(NumCounterSumArrChrs))   Len(TxtDelimiter)   NumSumArrChrs
    If CounterChr > NumSumArrChrs Then NumCounterSumArrChrs = NumCounterSumArrChrs   1
    Loop
    TxtDummy = IIf(TxtDummy = "", ArrTxtToAnalyze(NumCounterSumArrChrs), TxtDummy & TxtDelimiter & ArrTxtToAnalyze(NumCounterSumArrChrs))
    CounterChr = NumSumArrChrs   Len(TxtDelimiter)
    End If ' 1. If RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Font.Color = NumColorIndexSpecific
    Else ' 2. If IsWholeWordNeeded = True
    If RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Font.Color = NumColorIndexSpecific Then _
    TxtDummy = IIf(TxtDummy = "", RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Text, TxtDummy & RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Text)
    End If ' 2. If IsWholeWordNeeded = True
    Else ' 1. If IsColorSpecific = True
    If IsWholeWordNeeded = True Then ' 3. If IsWholeWordNeeded = True
    If RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Font.Color <> NumColorIndexIgnored Then ' 4. If RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Font.Color = NumColorIndexSpecific
    NumSumArrChrs = 0: NumCounterSumArrChrs = 0
    Do Until CounterChr <= NumSumArrChrs
    NumSumArrChrs = Len(ArrTxtToAnalyze(NumCounterSumArrChrs))   Len(TxtDelimiter)   NumSumArrChrs
    If CounterChr > NumSumArrChrs Then NumCounterSumArrChrs = NumCounterSumArrChrs   1
    Loop
    TxtDummy = IIf(TxtDummy = "", ArrTxtToAnalyze(NumCounterSumArrChrs), TxtDummy & TxtDelimiter & ArrTxtToAnalyze(NumCounterSumArrChrs))
    CounterChr = NumSumArrChrs   Len(TxtDelimiter)
    End If ' 4. If RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Font.Color = NumColorIndexSpecific
    Else ' 3. If IsWholeWordNeeded = True
    If RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Font.Color <> NumColorIndexIgnored Then _
    TxtDummy = IIf(TxtDummy = "", RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Text, TxtDummy & RangeTxtToAnalyze.Characters(Start:=CounterChr, Length:=1).Text)
    End If ' 3. If IsWholeWordNeeded = True
    End If ' 1. If IsColorSpecific = True
    Next CounterChr
    Return_TxtColored = TxtDummy
End Function