提取具有彩色字符的单词（甚至是单个彩色字符）

Question

具有 UDF，可以提取句子中具有任何颜色字符的单词。该代码正在运行，但速度太慢。我只测试了 300 行的代码，大约需要 15 分钟才能完成

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

是否有可能让它更快，或者是否有另一种有效的方法来完成这样的任务？

Answer 1

解决方案
测试了 500 行，整个逻辑大约需要 30 秒，没有我上面评论的代码加速优化（IE：screenupdating = False，应该更快）

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

提取具有彩色字符的单词（甚至是单个彩色字符）

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

excel

vba