基于另一张纸上的值(日期)的颜色单元格

Question

我在表2的D列上有几个日期。我想搜索工作表1的第一行，如果找到相同的日期，则为单元格上色，但似乎无法使其工作。我相信这个问题在范围内，但尝试了几种方法，都没有奏效。

请参阅下面的代码：

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

提前感谢

Answer 1

请测试下一种方法。它使用两个数组，以便在每个单元格之间进行更快的迭代，并为匹配的单元格创建一个Union范围，该范围将在最后一次着色：

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

初步清除第一行现有单元格的格式可能会很好，以便在下次运行代码时查看差异，但如果没有要求，我没有包括这样的方法。。。

现有代码错误地限定了使用的范围，使用活动工作表的相同cells来构建这两个范围。但我试图提供一种更快的方法来处理这个问题。