VBA to change color of partial text

[afeldsh]

Hello,

I need help with VBA to change color of partial text.

I am working with 2 worksheets. 1 worksheet is named "Reference Information", column A contains specific text. The list can grow over time.

Second worksheet is "Sourcing". I would like for VBA to look at the data in column Z of this worksheet, and if any of the text in this column, starting with 2nd row and up contains any text from column A of the "Reference Information" worksheet, to change color of that text only in red font, leaving remaining text font color as is.

Is this possible?

TIA
Alex

 

[SunnyAlv]

like this ?

Sub TextColor()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationAutomatic
On Error Resume Next
    
    Dim ref As Worksheet, src As Worksheet
    Dim c As Range, i As Long, x As Long, t As Long
  
    Set ref = ThisWorkbook.Sheets("Reference Information")
    Set src = ThisWorkbook.Sheets("Sourcing")
    
        For t = 2 To Application.CountA(src.Range("Z:Z")) 'Start from row 2
          If Not ref.Range("A" & t) = "" Then
          
                For Each c In src.Range("Z" & t, src.Range("Z" & Rows.Count).End(3))
                  x = 1
                  For i = 1 To (Len(c.Value) - Len(Replace(c.Value, ref.Range("A" & t).Value, "", , , vbTextCompare))) / Len(ref.Range("A" & t).Value)

                    With c.Characters(InStr(x, c.Value, ref.Range("A" & t).Value, 1), Len(ref.Range("A" & t).Value))
                      .Font.Bold = True
                      .Font.Color = vbRed
                    End With
                    x = InStr(x, c.Value, ref.Range("A" & t).Value, 1) + Len(ref.Range("A" & t).Value)
                  Next
                Next
        
                    Else
            
                With src.Range("Z" & t)
                    .Font.Bold = False
                    .Font.Color = vbBlack
                End With
            End If
        Next t
End Sub

 

[afeldsh]

like this ?

Sub TextColor()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationAutomatic
On Error Resume Next
 
    Dim ref As Worksheet, src As Worksheet
    Dim c As Range, i As Long, x As Long, t As Long
 
    Set ref = ThisWorkbook.Sheets("Reference Information")
    Set src = ThisWorkbook.Sheets("Sourcing")
 
        For t = 2 To Application.CountA(src.Range("Z:Z")) 'Start from row 2
          If Not ref.Range("A" & t) = "" Then
      
                For Each c In src.Range("Z" & t, src.Range("Z" & Rows.Count).End(3))
                  x = 1
                  For i = 1 To (Len(c.Value) - Len(Replace(c.Value, ref.Range("A" & t).Value, "", , , vbTextCompare))) / Len(ref.Range("A" & t).Value)

                    With c.Characters(InStr(x, c.Value, ref.Range("A" & t).Value, 1), Len(ref.Range("A" & t).Value))
                      .Font.Bold = True
                      .Font.Color = vbRed
                    End With
                    x = InStr(x, c.Value, ref.Range("A" & t).Value, 1) + Len(ref.Range("A" & t).Value)
                  Next
                Next
    
                    Else
        
                With src.Range("Z" & t)
                    .Font.Bold = False
                    .Font.Color = vbBlack
                End With
            End If
        Next t
End Sub

Does not seem to do anything. 1000, 2000, 3000 in the Sourcing tab, text color should have been red after running the VBA

 

[SunnyAlv]

the result will be like this, and I think you only need text equalization, not numbers, and what you attached are numbers

 

[afeldsh]

I appreciate you trying to help me with this. I might of provided a bad example. I am not sure if it matters what version of excel I am using, but the code is not doing anything on my side either way. I am using Microsoft Office 2021. I attached better examples. It needs to match exactly as on the "Reference Information". Here are some more examples.

 

[Fuji]

try

Sub test()
    Dim myList, e, r As Range, x&
    myList = Filter(Sheets("reference").[transpose(if(a1:a10000<>"",a1:a10000))], False, 0)
    With Sheets("sourcing")
        For Each r In .Range("z2", .Range("z" & Rows.Count).End(xlUp))
            If r <> "" Then
                If IsNumeric(r) Then r = "'" & r
                For Each e In myList
                    x = InStr(1, r, e, 1)
                    Do While x
                        With r.Characters(x, Len(e)).Font
                            .Color = vbRed: .Bold = True
                        End With
                        x = InStr(x + 1, r, 1)
                    Loop
                Next
            End If
        Next
    End With
End Sub

 

[afeldsh]

Here are the results I am getting, does not quite work as intended. Should match exactly as on Reference tab before font color change.

 

[Fuji]

Try this one then...

Sub test()
    Dim myList$, e, rng As Range, r As Range, m As Object
    myList = Join(Filter(Sheets("reference").[transpose(if(a1:a10000<>"",a1:a10000))], False, 0), Chr(2))
    With Sheets("sourcing")
        Set rng = .Range("z2", .Range("z" & Rows.Count).End(xlUp))
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True: .MultiLine = True
        .Pattern = "[$()^|\\\[\]{}+:?.-]"
        myList = Replace(.Replace(myList, "\$&"), Chr(2), "|")
        .Pattern = "\b(" & myList & ")\b"
        For Each r In rng
            If IsNumeric(r) Then r = "'" & r
            If .test(r) Then
                For Each m In .Execute(r)
                    With r.Characters(m.firstindex + 1, m.Length).Font
                        .Color = vbRed: .Bold = True
                    End With
                Next
            End If
        Next
    End With
End Sub

 

[afeldsh]

Try this one then...

Sub test()
    Dim myList$, e, rng As Range, r As Range, m As Object
    myList = Join(Filter(Sheets("reference").[transpose(if(a1:a10000<>"",a1:a10000))], False, 0), Chr(2))
    With Sheets("sourcing")
        Set rng = .Range("z2", .Range("z" & Rows.Count).End(xlUp))
    End With
    With CreateObject("VBScript.RegExp")
        .Global = True: .MultiLine = True
        .Pattern = "[$()^|\\\[\]{}+:?.-]"
        myList = Replace(.Replace(myList, "\$&"), Chr(2), "|")
        .Pattern = "\b(" & myList & ")\b"
        For Each r In rng
            If IsNumeric(r) Then r = "'" & r
            If .test(r) Then
                For Each m In .Execute(r)
                    With r.Characters(m.firstindex + 1, m.Length).Font
                        .Color = vbRed: .Bold = True
                    End With
                Next
            End If
        Next
    End With
End Sub

This works as intended. Thank you so much!

 

[Fuji]

You are welcome and thanks for the feedback.