Color multiple words inside a textjoin formula

Question

I have cells with a concatenated list of words (with textjoin) and I want to colorate words differently to make it more readable. Just an example to better explain my problem: 5 Apples / 2 Oranges / 3 Bananas / 5 Apples / 2 Kiwis / 3 Oranges I would need to put the apples in red and the oranges in orange.

Do you have a solution on this? Thanks in advance!

I was able to find an example on this forum to color text in cells using VBA and the InStr function, but the problem I am having is that the words are often repeated and InStr doesn't work for multiple entries:

AppleStartPosition = InStr(1, CurrentCellText, "Apple")
If AppleStartPosition > 0 Then
    ActiveSheet.Cells(Row, Col).Characters(AppleStartPosition, 5).Font.color = RGB(255, 0, 0)
End If

Answer 1

As @Rory commented first convert to static value the cell content e.g. with Copy and PasteSpecial/Values either in excel or in vba and then

This is an example code where

cellofrange is the range to color

colarr is the array of the colors to apply

this colors the letters only and change a color when a non letter character found.

Sub colorer()
    Dim cellofrange As Range, cellof As Range
    Set cellofrange = Range("a19:a24")
    colarr = Array(rgbSeaGreen, rgbSienna, rgbSlateGrey, rgbSlateBlue, rgbSkyBlue)
    colpointer = 0
    For Each cellof In cellofrange
        changed = False
        stringtocolor = cellof.Value
        For i = 1 To Len(stringtocolor)
            charact = Mid(stringtocolor, i, 1)
            If Asc(charact) > 64 And Asc(charact) < 91 Or Asc(charact) > 96 And Asc(charact) < 123 Then
                cellof.Characters(i, 1).Font.Color = colarr(colpointer)
                changed = False
            ElseIf Not changed Then
                changed = True
                If colpointer = UBound(colarr) Then
                    colpointer = 0
                Else
                    colpointer = colpointer + 1
                End If
            End If
        Next i
    Next cellof
End Sub

Answer 2

Here is how I tackled this issue using regex. I've been looping a dictionary as an example, making sure in the pattern that we are being explicit about the value we are looking for using boundaries! This way I tried to minimize the possibility of false positives being colored. For example 'Apple' in 'Apple Pie'.

---

Sub Test()

Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim re As Object: Set re = CreateObject("vbscript.regexp")
Dim cl As Range: Set cl = ThisWorkbook.Worksheets("Sheet1").Range("A1")

'Assert we are dealing with a value instead of formula:
cl.Value = cl.Value

'Choose how you wish to run through word/color combo's. I used a dictionary:
dict.Add "Apples", 3
dict.Add "Oranges", 46

'Loop through the dictionary, adjust the regex pattern and replace font colors:
For Each Key In dict.Keys
    With re
        .Global = True
        .Pattern = "(\d\s)" & Key & "(?=\s+\/|$)"
        If .Test(cl) Then
            For Each rMatch In .Execute(cl.Value)
                cl.Characters(rMatch.FirstIndex + 3, rMatch.Length - 2).Font.ColorIndex = dict(Key)
            Next rMatch
        End If
    End With
Next Key

End Sub

---

If you need to color the actual numbers too then:

Sub Test()

Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim re As Object: Set re = CreateObject("vbscript.regexp")
Dim cl As Range: Set cl = ThisWorkbook.Worksheets("Sheet1").Range("A1")

'Assert we are dealing with a value instead of formula:
cl.Value = cl.Value

'Choose how you wish to run through word/color combo's. I used a dictionary:
dict.Add "Apples", 3
dict.Add "Oranges", 46

'Loop through the dictionary, adjust the regex pattern and replace font colors:
For Each Key In dict.Keys
    With re
        .Global = True
        .Pattern = "\d+\s" & Key & "(?=\s+\/|$)"
        If .Test(cl) Then
            For Each rMatch In .Execute(cl.Value)
                cl.Characters(rMatch.FirstIndex + 1, rMatch.Length).Font.ColorIndex = dict(Key)
            Next rMatch
        End If
    End With
Next Key

End Sub

Answer 3

Here is the code snipped:

Option Explicit
'
' cell A1 contains:
' 5 Apples / 2 Oranges / 3 Bananas / 5 Apples / 2 Kiwis / 3 Oranges / 4 Raspberries
'
' The second parameter is the HighLight String a # symbol and the color in hex

Sub TEST()
    ColorCell Range("A1:A3"), "Apples#FF0000,Oranges#00FF00"
End Sub


Private Sub ColorCell(cellRange As Range, ColorOpt As String, Optional Separator = " ")
Dim aItems() As String, aColorOpt() As String, aItm() As String, ColorTab() As Variant, aCell() As String
Dim i As Integer, j As Integer, tx As String, element As String, Item As String, co As String, mx As Long, rr As Range, po As Integer

    
    aColorOpt = Split(ColorOpt, ",")
    mx = UBound(aColorOpt)
    ReDim ColorTab(mx, 1)
    For i = 0 To mx
        aItm = Split(aColorOpt(i), "#")
        Item = aItm(0)
        co = aItm(1)
        ColorTab(i, 0) = Item
        ColorTab(i, 1) = co
    Next
            
    For Each rr In cellRange.Cells
        aItems = Split(rr.Value, Separator)
        rr.Font.ColorIndex = xlAutomatic
        rr.Font.TintAndShade = 0
        po = 1
        For i = 0 To UBound(aItems)
            For j = 0 To mx
                If (InStr(Trim(LCase(aItems(i))), Trim(LCase(ColorTab(j, 0)))) > 0) Then
                    rr.Characters(po, Len(aItems(i))).Font.Color = Val("&H" & ColorTab(j, 1))
                End If
            Next
            po = po + Len(aItems(i)) + 1
        Next
    Next
End Sub