Extract colored strings within cell

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Extract colored strings within cell

Post by YasserKhalil »

Hello everyone
I am trying to extract the words in cells that are colored in red. Here's what I have tried till now

Code: Select all

Sub Test()
    Dim a()
    a = GetColorText(ActiveCell)
End Sub

Function GetColorText(r As Range)
    Dim a(), b As Boolean, s As String, t As String, x As Long, i As Long
    t = r.Text
    For x = 1 To Len(t)
        If r.Characters(x, 1).Font.Color = vbRed Then
            b = True: s = s & Mid(t, x, 1)
        Else
            b = False
        End If
        If b = False And s <> "" Then
            ReDim Preserve a(i): a(i) = s: i = i + 1: s = vbNullString
        End If
    Next x
    GetColorText = a
End Function
There are supoerscripts characters that I need to skip during this process ..
Finally to list the extracted words into column G for example

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Extract colored strings within cell

Post by HansV »

I'm disappointed that you can't solve this yourself...

Code: Select all

Sub Test()
    Dim a()
    a = GetColorText(ActiveCell)
    Range("G1").Resize(UBound(a) + 1) = Application.Transpose(a)
End Sub

Function GetColorText(r As Range)
    Dim a(), b As Boolean, s As String, t As String, x As Long, i As Long
    t = r.Text
    For x = 1 To Len(t)
        If r.Characters(x, 1).Font.Color = vbRed And Not r.Characters(x, 1).Font.Superscript Then
            b = True: s = s & Mid(t, x, 1)
        Else
            b = False
        End If
        If b = False And s <> "" Then
            ReDim Preserve a(i): a(i) = s: i = i + 1: s = vbNullString
        End If
    Next x
    GetColorText = a
End Function
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract colored strings within cell

Post by YasserKhalil »

Thank you very much my tutor.
In fact, I am trying to explore more so the thread is not about to remove the siperscript only.
What I am trying to know: Is there a way to store the string into variable instead of dealing directly with the cell as the code takes too long time too process such a task?

I have tested the code. There is a problem for that cell
01.png
The code extracts two separate words while I expect the both words to be extracted as one word. so how can I skip the comma from that code so as to treat the comma as part of the word
You do not have the required permissions to view the files attached to this post.
Last edited by YasserKhalil on 08 Oct 2020, 16:13, edited 1 time in total.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Extract colored strings within cell

Post by HansV »

You do have to deal with the cell because the Characters property of the cell contains the formatting information that you need. The Characters object is not a simple string.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract colored strings within cell

Post by YasserKhalil »

Thanks a lot for the information.
I have added a point that I encountered with using comma (which is not red)

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Extract colored strings within cell

Post by HansV »

This is getting fairly ridiculous, but here you go.

Code: Select all

Function GetColorText(r As Range)
    Dim a(), b As Boolean, s As String, t As String, x As Long, i As Long
    t = r.Text
    For x = 1 To Len(t)
        If r.Characters(x, 1).Font.Color = vbRed And Not r.Characters(x, 1).Font.Superscript Then
            b = True: s = s & Mid(t, x, 1)
        ElseIf b And r.Characters(x, 1).Text = "," Then
            ' Do nothing
        ElseIf b And r.Characters(x, 1).Text = " " Then
            s = s & Mid(t, x, 1)
        Else
            b = False
        End If
        If b = False And s <> "" Then
            ReDim Preserve a(i): a(i) = s: i = i + 1: s = vbNullString
        End If
    Next x
    GetColorText = a
End Function
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract colored strings within cell

Post by YasserKhalil »

Thanks a lot my tutor. I know that may seem ridiculous.
Please have a look at this sample (I wonder why it doesn't work for that point)
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Extract colored strings within cell

Post by HansV »

Some of the spaces in the cell value are non-breaking spaces.

Code: Select all

Function GetColorText(r As Range)
    Dim a(), b As Boolean, s As String, t As String, x As Long, i As Long
    t = r.Text
    For x = 1 To Len(t)
        If r.Characters(x, 1).Font.Color = 8388619 And Not r.Characters(x, 1).Font.Superscript Then
            b = True: s = s & Mid(t, x, 1)
        ElseIf b And r.Characters(x, 1).Text = "," Then
            ' Do nothing
        ElseIf b And (r.Characters(x, 1).Text = " " Or r.Characters(x, 1).Text = Chr(160)) Then
            s = s & Mid(t, x, 1)
        Else
            b = False
        End If
        If b = False And s <> "" Then
            ReDim Preserve a(i): a(i) = s: i = i + 1: s = vbNullString
        End If
    Next x
    GetColorText = a
End Function
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract colored strings within cell

Post by YasserKhalil »

Thanks a lot for this amazing solution.
The code takes about 15 seconds for just one cell. I have about 1000 cells. Is there any opportunity to accelerate such process or this is road-blocked :) ?

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Extract colored strings within cell

Post by HansV »

The code has to perform an enormous amount of checks. I don't see a way to speed it up.
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Extract colored strings within cell

Post by YasserKhalil »

Thank you very much for the great assistance my tutor.
Best and Kind Regards