VBA to colour cells if cell value matches

Question

I am relatively new to VBA and have this script which searches for the Array "VC" and changes the matching cells within the range by colouring them red.

My problem is I need to change the criteria from -MyArr = Array("VC") to instead search column A and find any corresponding matches in the same row within the range "B2:D20" then colour the matches red as the below script does.

As per the below script I don't want a case sensitive search and am using XLpart to include partial matches. Please help, thanks

Sub Mark_cells_in_column()
    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim I As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    MyArr = Array("VC")
    With Sheets("Sheet1").Range("A2:d20")
        For I = LBound(MyArr) To UBound(MyArr)
             Set Rng = .Find(What:=MyArr(I), _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rng.Interior.ColorIndex = 3
                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

---

Sample data:

Answer 1

This will go through all cells in column A, split each cell value (comma-delimited) into separate items, and search for each item in the same row (case insensitive), through columns B to D

---

Option Explicit

Public Sub MarkCellsInColumns()
    Dim arr As Variant, r As Long, c As Long, i As Long, f As Range, vals As Variant

    arr = Sheet1.UsedRange

    With Sheet1.UsedRange
        For r = 1 To UBound(arr)
            If Not IsError(arr(r, 1)) Then
                If Len(arr(r, 1)) > 0 Then

                    vals = Split(arr(r, 1), ",")        'check each value in one cell
                    For i = 0 To UBound(vals)
                        For c = 2 To UBound(arr, 2)     'check all columns on same row
                            If LCase(Trim$(vals(i))) = LCase(Trim$(arr(r, c))) Then
                                If f Is Nothing Then
                                    Set f = .Cells(r, c)
                                Else
                                    Set f = Union(f, .Cells(r, c))  'union of found cells
                                End If
                                f.Select
                            End If
                        Next c
                    Next i

                End If
            End If
        Next r
        If Not f Is Nothing Then f.Interior.Color = vbRed   'color all in one operation
    End With
End Sub

---

Result

Answer 2

You may try this

Public Sub Main()
    Dim cell As Range, cell2 As Range
    For Each cell In ThisWorkbook.Worksheets("Sheet1").Range("A2:A20")
        For Each cell2 In cell.Offset(, 1).Resize(, 3)
            If Instr(cell.Value, cell2.Value) > 0 Then cell2.Interior.ColorIndex = 3
        Next
    Next 
End Sub

Or

Public Sub Main()
    Dim cell As Range
    With ThisWorkbook.Worksheets("Sheet1")
        For Each cell In .Range("B:D").SpecialCells(xlCellTypeConstants)
            If Instr(.Cells(cell.Row,1).Value, cell.Value) > 0 Then cell.Interior.ColorIndex = 3
        Next
    End With 
End Sub