如果值与列中其他工作表的值匹配，则更改单元格的颜色

问题描述

这是代码。我有一个日历，日历的日期为B4：H9。如果这些日期在列表中（列，在不同的工作表上），我想更改单元格的颜色。 如果工作表中有许多不同的日期，运行起来可能会很繁琐，但这没关系。

我在这里做错了什么？尝试不同的操作时，它会不断为我提供不同的错误代码。

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

解决方法

如SuperSymmetry所述，定义对象（例如范围，图纸）时，您需要使用Set关键字。我将不作解释。但是我想提的几件事...

1. 尝试提供有意义的变量名，以便您了解它们的用途。
2. 使用对象，以便您的代码知道您要引用的工作表，范围。
3. 不需要第二个循环。使用.Find搜索您的数据。会更快
4. 要设置RGB，您需要.Color而不是.ColorIndex

这是您要尝试的吗？ （未经测试）

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

,

这应该可以解决问题，我不喜欢在没有工作表的情况下离开范围，但是由于我相信您正在使用按钮，因此应该没有问题：

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,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

,

• 定义对象（例如范围，图纸）时，需要使用setlocal /?关键字

Set

• Set area = Range("B4:H9") Set columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count) 接受Worksheets()或Integer。因此，String的类型应为sheet

String

您还将Dim sheet As String 设置为工作表的整个列，因此不必要地循环了数十万次。更改为

columnlist

以上内容应解决代码中的错误，并使其运行更快。但是，代码的效率仍有很大的改进空间。例如，您应该建立一个范围并在循环后设置一次颜色，而不是在循环内更改颜色。

还可以考虑在代码开头使用

重置颜色

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

我个人会使用注释中建议的@SiddharthRout的条件格式。

编辑评论后

这是我的演出

area.Interior.Pattern = xlNone

使用2500个日期列表，我的机器上花了0.0742秒。