Change the font color in a cell based on the value in another cell

Question

I would like to change the color of certain text in the cells based on the values in another cells. I have tried using conditional formatting but it does not work since I only wanted to change the color of particular words in the cells. I have googled a few VBA codes as well but still could not find the right one. Is there any VBA Code to enable this?

As shown in the example below (see image), I want to highlight ONLY the dates in Column B and C that match the dates in Column G. The day should remain the same.

For information, the values in Column B and C are formatted as text and the values in G are formatted as date.

Before

and this is basically what I wish for.

After

Answer 1

I have modified code appropriately as per your requirement in the comment.

Sub Change_Text_Color()

Dim Find_Text, Cell, Cell_in_Col_G, LastCell_inColG As Range
Dim StartChar, CharLen, LastUsedRow_inRange, LastUsedRow_inColB, _
LastUsedRow_inColC As Integer

LastUsedRow_inColB = Sheet1.Cells(Rows.count, "B").End(xlUp).Row
LastUsedRow_inColC = Sheet1.Cells(Rows.count, "C").End(xlUp).Row
LastUsedRow_inRange = Application.WorksheetFunction. _
Max(LastUsedRow_inColB, LastUsedRow_inColC)

Set LastCell_inColG = Sheet1.Cells(Rows.count, "G").End(xlUp)

    For Each Cell In Range(Sheet1.Cells(2, 2), Cells(LastUsedRow_inRange, 3))
        
        For Each Cell_in_Col_G In Range(Sheet1.Cells(2, 7), LastCell_inColG)
            
            CharLen = Len(Cell_in_Col_G.Text)  
            Set Find_Text = Cell.Find(what:=Cell_in_Col_G.Text)
        
            If Not Find_Text Is Nothing Then
                StartChar = InStr(Cell.Value, Cell_in_Col_G.Text)        
                With Cell.Characters(StartChar, CharLen)
                    .Font.Color = RGB(0, 255, 0)
                End With                
            End If
        Next
    Next
End Sub

Please let me know your feedback on it.

Answer 2

Use Characters :

With Range("a1")
.Characters(Start:=1, Length:=4).Font.Color=0
.Characters(Start:=5, Length:=10.Font.Color=255
End With

colours the first four letters black and the next ten in red.

Ref:

• https://docs.microsoft.com/en-us/office/vba/api/excel.characters

Answer 3

I find filtering works well in these scenarios. Assuming that the format of your sheet is as it is in your sample sheets, try the code below:

Sub MarkDatesInCells()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3")        '<- Change to the sheet name
    Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
    Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
    Dim sColName As String
    
    ' Turn off updating
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    With oWS
        
        ' Clear autofilter if exists
        If .AutoFilterMode Then .AutoFilterMode = False
        
        ' Loop through all values specified in column G
        iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
        For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
        
            ' Loop through column B and C
            For iC = 2 To 3
            
                ' Set autofilter based on the value in column G
                .UsedRange.AutoFilter iC, "=*" & oHighlightRng.Value
                
                ' Loop through all visible rows
                iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
                If iLR > 1 Then
                
                    sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
                    
                    Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
                    
                    ' Update each cell text
                    For Each oRng In oUpdateRng
                        
                        iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
                        oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
                    
                    Next
                    
                End If
                
                .AutoFilterMode = False
        
            Next
            
        Next
        
    End With
    
    ' Turn on updating
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

EDIT

Based on your requirement to have this solution for a sheet with a table connected to a database, try the below code. I don't have a database that I can test the below code on so you might have to tinker with it a bit to get it right (ie the text that is highlight)

Sub MarkDatesInCellsInATable()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4")        '<- Change to the sheet name
    Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
    Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
    Dim sColName As String
    Dim oTable As ListObject: Set oTable = oWS.ListObjects("Table_ExceptionDetails.accdb")  '<- Change to the table name
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    With oWS
        
        ' Reset autofilter
        oTable.Range.AutoFilter
        
        ' Loop through all values specified in column G
        iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
        For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
        
            ' Loop through column B and C
            For iC = 2 To 3
            
                ' Set autofilter based on the value in column G
                oTable.Range.AutoFilter iC, "=*" & oHighlightRng.Value & "*"
                
                ' Loop through all visible rows
                iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
                If iLR > 1 Then
                
                    sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
                    
                    Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
                    
                    ' Update each cell text
                    For Each oRng In oUpdateRng
                        
                        iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
                        oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
                    
                    Next
                    
                End If
                
                oTable.Range.AutoFilter
        
            Next
            
        Next
        
    End With
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub