Excel VBA实现根据日期条件自动更改单元格颜色方法求助

• 同一工作表模块内重复定义了2个完全相同的Worksheet_Change事件，VBA仅会识别其中一个，重复定义会导致事件触发逻辑混乱
• 事件监听范围仅覆盖D列，未包含需要监控变更的E:H列，修改E到H列日期时不会自动触发颜色更新
• 存在无效冗余代码：未定义的Oval对象赋值、错误使用Set给非对象类型的日期变量赋值（Set仅可用于对象类型赋值）
• 颜色计算逻辑错误：r2是多单元格区域，直接取r2.Value只会返回区域左上角单元格的值，无法逐单元格判断日期差；判断阈值重叠，diff < 11的条件会覆盖所有小于等于10的场景，导致红色填充规则永远不会触发
• 循环行范围写死为2-5行，无法适配后续新增的跟踪数据
• 修改单元格值时未临时关闭事件响应，会反复触发Change事件造成死循环
• 缺少空值、日期格式校验，D列或E:H列为空、值为非日期格式时，日期差计算会直接报错
• 保留了调试用的弹窗提示，每次触发更新都会弹出提示框影响正常使用

将原有工作表模块内的代码全部删除，替换为以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim watchRng As Range
    Set watchRng = Application.Union(Range("D:D"), Range("E:H"))
    
    If Intersect(Target, watchRng) Is Nothing Then Exit Sub
    
    ' 临时关闭事件，避免修改单元格时递归触发事件
    Application.EnableEvents = False
    On Error GoTo ErrHandle
    
    Dim cell As Range
    For Each cell In Intersect(Target, watchRng)
        ' 处理D列截止日期变更
        If Not Intersect(cell, Range("D:D")) Is Nothing Then
            If cell.Value = "" Then
                cell.Offset(0, 1).Resize(1, 4).ClearContents
            Else
                ' 若不需要D列填值后E:H自动填充当前日期，注释掉下一行即可
                cell.Offset(0, 1).Resize(1, 4).Value = Date
            End If
        End If
    Next
    
    Call ColorMeElmo

ErrHandle:
    ' 必须恢复事件响应，否则后续所有单元格操作都不会触发事件
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "运行错误：" & Err.Description, vbExclamation
End Sub

Sub ColorMeElmo()
    Dim lastRow As Long, i As Long
    Dim deadlineCell As Range, dateCell As Range
    Dim diff As Long
    
    Application.ScreenUpdating = False
    
    ' 自动识别D列最后一行有效数据，无需手动写死行范围
    lastRow = Cells(Rows.Count, "D").End(xlUp).Row
    If lastRow < 2 Then GoTo Finish
    
    ' 先清空旧填充色，避免格式残留
    Range("E2:H" & lastRow).Interior.ColorIndex = xlNone
    
    For i = 2 To lastRow
        Set deadlineCell = Range("D" & i)
        ' 跳过截止日期为空、非日期格式的行
        If deadlineCell.Value <> "" And IsDate(deadlineCell.Value) Then
            ' 逐单元格判断E:H列日期
            For Each dateCell In Range("E" & i & ":H" & i)
                If dateCell.Value <> "" And IsDate(dateCell.Value) Then
                    diff = DateDiff("d", deadlineCell.Value, dateCell.Value)
                    ' 颜色规则可按需调整阈值
                    Select Case diff
                        Case Is > 10: dateCell.Interior.Color = vbRed
                        Case 1 To 10: dateCell.Interior.Color = vbYellow
                        Case Is <= 0: dateCell.Interior.Color = vbGreen ' 早于截止日期显示绿色，不需要可删除
                    End Select
                End If
            Next
        End If
    Next i

Finish:
    Application.ScreenUpdating = True
End Sub

• 按Alt+F11打开VBA编辑器，在左侧工程面板双击对应跟踪表的工作表模块，清空原有代码后粘贴上述内容
• 颜色阈值、对应填充色可直接修改Select Case分支的判断条件和颜色值，比如不需要绿色提示直接删除对应行即可
• 如果不需要D列填入截止日期后自动给E:H列填充当前日期，注释掉对应代码行即可
• 代码会自动适配新增的数据行，不需要手动调整循环范围

内容的提问来源于stack exchange，提问作者Vinu Varghese