Change color of cells if the value matches values of other worksheets values in a column

Question

So here's the code. I have a calendar with dates in B4:H9. I want to change the color of the cells if the those dates are in a list (column, on different worksheet). This might be a bit heavy to run if there are many different dates in the worksheet, but that doesn't matter.

What am I doing wrong here? It keeps giving me different error codes, when trying different things.

Sub check_Click()
Dim area As Range
Dim item1 As Range
Dim item2 As Range
Dim sheet As Worksheet
Dim columnlist As Range


sheet = Range("E2").Value
area = Range("B4:H9")
columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)

For Each item1 In area
            For Each item2 In columnlist
                If item1.Value = item2.Value Then
                item1.Interior.ColorIndex = RGB(255, 255, 0)
                End If
                
            Next item2
            Next item1
End Sub

Answer 1

• When you define objects (e.g. ranges, sheets) you need to use the Set keyword

Set area = Range("B4:H9")
Set columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)

• Worksheets() accepts either an Integer or a String. Therefore, sheet should be of Type String

Dim sheet As String

You're also setting columnlist to the whole column in the sheet so you're looping hundreds of thousands more times unncessarily. Change it to

    With Worksheets(sheet)
        Set columnlist = .Range(.Range("A2"), .Range("A" & Rows.Count).Offset(xlUp))
    End With

The above should fix the errors in your code and make it run a little faster. However, there's still big room for improvment in the efficiency of the code. For example, instead of changing the colour inside the loop, you should build a range and set the colour one time after the loop.

Also consider resetting the colour at the beginning of the code with

area.Interior.Pattern = xlNone

I would personally go with conditional formatting as @SiddharthRout suggested in the comments.

Edit following comment

Here's my rendition

Sub check_Click()
    Dim dStart As Double
    dStart = Timer

    Dim rngCalendar As Range
    Dim vCalendar As Variant
    Dim shtDates As Worksheet
    Dim vDates As Variant, v As Variant
    Dim i As Long, j As Long
    Dim rngToColour As Range
    
    ' Change the sheet name
    With ThisWorkbook.Sheets("Calendar")
        Set rngCalendar = .Range("B4:H9")
        vCalendar = rngCalendar.Value
        Set shtDates = ThisWorkbook.Sheets(.Range("E2").Value)
    End With
    
    With shtDates
        vDates = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Value
    End With
    
    For i = 1 To UBound(vCalendar, 1)
        For j = 1 To UBound(vCalendar, 2)
            For Each v In vDates
                If v <> vbNullString And v = vCalendar(i, j) Then
                    If rngToColour Is Nothing Then
                        Set rngToColour = rngCalendar.Cells(i, j)
                    Else
                        Set rngToColour = Union(rngToColour, rngCalendar.Cells(i, j))
                    End If
                    Exit For
                End If
            Next v
        Next j
    Next i
        
    rngCalendar.Interior.Pattern = xlNone
    If Not rngToColour Is Nothing Then
        rngToColour.Interior.Color = RGB(255, 255, 0)
    End If
    
    MsgBox "Time taken: " & Format(Timer - dStart, "0.0000s")
End Sub

With a list of 2500 dates it took 0.0742s on my machine.

Answer 2

This should do the trick, I don't like leaving ranges without their sheet, but since I believe you are using a button, there should be no problem:

Option Explicit
Sub check_Click()
    
    'We are going to use a dictionary, for it to work you need to:
    'Go to Tools-References-Check the one called: Microsoft Scripting Runtime
    Dim DatesToChange As Dictionary: Set DatesToChange = LoadDates
    Dim area As Range: Set area = Range("B4:H9")
    Dim item As Range
    For Each item In area
        If DatesToChange.Exists(item.Value) Then
            item.Interior.Color = RGB(255, 255, 0)
        End If
    Next item

End Sub
Private Function LoadDates() As Dictionary

    Set LoadDates = New Dictionary
    Dim arr As Variant: arr = ThisWorkbook.Sheets(Range("E2")).Range("A:A")
    Dim i As Long
    For i = 2 To UBound(arr)
        'This here will break the loop when finding an empty cell in column A
        If arr(i, 1) = vbNullString Then Exit For
        'This will add all your dates in a dictionary (avoiding duplicates)
        If Not LoadDates.Exists(arr(i, 1)) Then LoadDates.Add arr(i, 1), 1
    Next i
    
End Function

Answer 3

As SuperSymmetry mentioned, when you define objects (e.g. ranges, sheets) you need to use the Set keyword. I will not get into that explanation. However few things that I would like to mention...

1. Try and give meaningful variable names so that you can understand what are they for.
2. Work with objects so that your code knows which sheet, which range are you referring to.
3. No need of 2nd loop. Use .Find to search for your data. It will be much faster
4. To set RGB, you need .Color and not .ColorIndex

Is this what you are trying? (Untested)

Option Explicit

Sub Check_Click()
    Dim rngData As Range
    Dim rngReference As Range
    Dim aCell As Range
    Dim matchedCell As Range
    
    Dim ws As Worksheet
    Dim lastRow As Long
    
    Dim worksheetName As String
    
    '~~> Change the sheet name accordingly
    worksheetName = ThisWorkbook.Sheets("Sheet1").Range("E2").Value
    
    Set ws = ThisWorkbook.Sheets(worksheetName)
    
    With ws
        '~~> Find the last row in Col A
        lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Set your range
        Set rngData = .Range("B4:H9")
        Set rngReference = .Range("A2:A" & lastRow)
        
        '~~> Loop through your data and use .Find to check if the date is present
        For Each aCell In rngData
            Set matchedCell = rngReference.Find(What:=aCell.Value, _
                                                LookIn:=xlValues, _
                                                LookAt:=xlWhole, _
                                                SearchOrder:=xlByRows, _
                                                SearchDirection:=xlNext, _
                                                MatchCase:=False, _
                                                SearchFormat:=False)
     
            If Not matchedCell Is Nothing Then
                '~~> Color the cell
                matchedCell.Interior.Color = RGB(255, 255, 0)
            End If
        Next aCell
    End With
End Sub