Using VBA to format multiple cells of a sheet based on the cells value of another she

[shaeto]

Dear Community,

I would be grateful if you could please provide me with suggestions regarding the following:

I have a worksheet (Sheet4) whereby users will be inputting some text. Each entry is related to a date which is displayed into another cell.
I'm looking for a way (VBA Code or Formula) to colour the corresponding date cell which is found in another worksheet (Sheet3).

In a nutshell the idea is:

IF cell B6 or cell D6 of Sheet4 contains any text value Then
colour format cell B3 of Sheet3
Else
Do not format cell colour of B3 (Sheet3)

So,

Sheet4		Sheet3
IF B6 or D6 has any text value	Then	B3 is filled in red
IF B7 or D7 has any text value	Then	J3 is filled in red
IF B8 or D8 has any text value	Then	R3 is filled in red
IF B9 or D9 has any text value	Then	Z3 is filled in red
IF B10 or D10 has any text value	Then	AH3 is filled in red

I tried to use the in-built conditional formatting tool but there is a lot of cell to apply same to.
As a novice, I try VBA and came up with the following:

Option Explicit 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 
    Dim var1 As String, var2 As String 
    var1 = Len(Worksheets("Sheet4").Range("B6")) 
    var2 = Len(Worksheets("Sheet4").Range("D6"))If var1 > 0 Then 
    Worksheets("Sheet3").Range("B3").Interior.Color = RGB(255, 0, 0) 
        Else 
    Worksheets("Sheet3").Range("B3").Interior.Color = xlNone 
    End If 
    If var2 > 0 Then 
    Worksheets("Sheet3").Range("B3").Interior.Color = RGB(255, 0, 0) 
        Else 
    Worksheets("Sheet3").Range("B3").Interior.Color = xlNone 
    End If 
End Sub

The above works fine but is quite tedious.

Attached is a sample workbook, the above code is found in sheet2.

Thank you beforehand for your comments and recommendations.

Best regards,

Shameem

[SamT]

Put this in Sheet2

Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Intersect(Range("B:B"), Target) Is Nothing) _
    And (Intersect(Range("D:D"), Target) Is Nothing) Then _
    ColorCells Target
End Sub

Sub ColorCells(Rng As Range)
Dim DateSheet As Worksheet
Set DateSheet = ThisWorkbook.Sheets("Sheet3")
Dim Col As String

Select Case Rng.Row
  Case 6: Col = "B"
  Case 7: Col = "J"
  Case 8: Col = "R"
  Case 9: Col = "Z"
  Case 10: Col = "AH"
End Select

With DateSheet.Range(Col & "3").Interior
If Rng.Value = "" Then
  .ColorIndex = xlColorIndexNone
Else
  .ColorIndex = 3
End If
End With 
End Sub

[shaeto]

Thanks a lot SamT.

It works like a charm.

Cheers

Shameem