VBA to colour cells if cell value matches - vba

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

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

Answer 2

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