colour cell based on value (date) on another sheet-CodePudding

I have several dates on the Column D of sheet 2. I want to search the first row of sheet 1 and if the same date is found colour the cells but can't seem to make it work. I believe the issue is on the ranges, but tried several ways and nothing works.

Please see my code below:

Sub test2()

Dim xcel As Range
Dim ycel As Range
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lc As Long
Dim lr As Long

Set WS1 = ThisWorkbook.Worksheets("sheet1")
Set WS2 = ThisWorkbook.Worksheets("sheet2")


lc = WS1.Cells(1, Columns.Count).End(xlToLeft).Column
lr = WS2.Range("D" & Rows.Count).End(xlUp).Row

With WS1
    For Each xcel In .Range(Cells(1, 1), Cells(1, lc))
        For Each ycel In WS2.Range(Cells(2, 4), Cells(lr, 4))
            If xcel.Value = ycel.Value Then
                xcel.Interior.ColorIndex = 6
                xcel.Font.ColorIndex = 1
            End If
        Next ycel
    Next xcel
End With
End Sub

thank you in advance

CodePudding user response：

Please, test the next way. It uses two arrays, for faster iteration against iteration between each cells and create a Union range for the matching cells, which to be colored at the end, at once:

Sub test2ColorCellInt()
 Dim WS1 As Worksheet, arr1, WS2 As Worksheet, arr2
 Dim lc As Long, lr As Long, i As Long, j As Long, rngCol As Range

 Set WS1 = ThisWorkbook.Worksheets("sheet1")
 Set WS2 = ThisWorkbook.Worksheets("sheet2")


 lc = WS1.cells(1, Columns.count).End(xlToLeft).Column
 lr = WS2.Range("D" & rows.count).End(xlUp).row
 arr1 = WS1.Range(WS1.cells(1, 1), WS1.cells(1, lc)).value 'place the range in an array for faster iteration
 arr2 = WS2.Range(WS2.cells(2, 4), WS2.cells(lr, 4)).value 'place the range in an array for faster iteration

 For i = 1 To UBound(arr1, 2) 'iterate on columns of arr1:
    For j = 1 To UBound(arr2) 'iterate between rows of arr2:
        If arr1(1, i) = arr2(j, 1) Then 'in case of a match:
            If rngCol Is Nothing Then   'if the range to keep the matching cells is nothing
                Set rngCol = WS1.cells(1, i) 'create the range
            Else
                Set rngCol = Union(rngCol, WS1.cells(1, i)) 'make a Union between existing and the matching cell
            End If
        End If
    Next j
 Next i
 If Not rngCol Is Nothing Then 'if the range exists, do the job:
    rngCol.Interior.ColorIndex = 6
    rngCol.Font.ColorIndex = 1
 End If
End Sub

It, probably, will be good to preliminarily clear the format of the first row existing cells, to see the differences when running the code next time, but if not requested, I did not include such an approach...

Your existing code wrongly qualified the used ranges, using the same cells of the active sheet for building both of them. But I tried to supply a faster way of dealing with the issue.