Excel VBA逾期日期单元格着色代码无法在文件打开时自动运行求解决

原代码存在的问题 #

• Sheet1_WorksheetChange是私有过程，Workbook_Open所在的ThisWorkbook模块无法直接调用
• Worksheet_Change事件内重复调用同名私有过程，逻辑冗余且易引发冲突
• 未处理单元格内容非有效日期的场景，会触发运行时错误
• 未考虑清空不符合条件单元格的原有底色（比如日期更新后，旧的颜色不会自动清除）

修正后的代码实现 #

1. 工作表模块（"2023"工作表） #

打开VBE编辑器，找到对应工作表模块，替换为以下代码：

' 公共过程：检查日期并设置单元格底色
Public Sub CheckDateAndColor(ByVal Target As Range)
    Dim cell As Range
    Dim dateCol As Range
    
    ' 限定目标范围为E11开始的日期列有效区域
    Set dateCol = Me.Range("E11:E" & Me.Cells(Me.Rows.Count, "E").End(xlUp).Row)
    Set Target = Intersect(Target, dateCol)
    
    ' 如果目标范围为空，直接退出
    If Target Is Nothing Then Exit Sub
    
    ' 关闭事件触发，避免循环调用
    Application.EnableEvents = False
    
    For Each cell In Target
        ' 先清空原有底色
        cell.Interior.ColorIndex = xlColorIndexNone
        
        ' 仅处理有效日期单元格
        If IsDate(cell.Value) Then
            Select Case cell.Value
                Case <= Date
                    cell.Interior.Color = RGB(255, 0, 0) ' 逾期：红色
                Case <= Date + 7
                    cell.Interior.Color = RGB(255, 255, 0) ' 7天内到期：黄色
                Case <= Date + 14
                    cell.Interior.Color = RGB(255, 165, 0) ' 8-14天到期：橙色
            End Select
        End If
    Next cell
    
    ' 恢复事件触发
    Application.EnableEvents = True
End Sub

' 单元格内容变更时触发
Private Sub Worksheet_Change(ByVal Target As Range)
    Call CheckDateAndColor(Target)
End Sub

2. ThisWorkbook模块 #

打开ThisWorkbook模块，替换为以下代码：

Private Sub Workbook_Open()
    Dim ws As Worksheet
    Dim targetRange As Range
    
    Set ws = ThisWorkbook.Sheets("2023")
    ' 获取E列从E11开始的所有有效数据单元格
    Set targetRange = ws.Range("E11:E" & ws.Cells(ws.Rows.Count, "E").End(xlUp).Row)
    
    ' 调用公共过程批量着色
    Call ws.CheckDateAndColor(targetRange)
End Sub

关键改进点 #

• 将日期检查逻辑封装为公共过程，确保Workbook_Open和Worksheet_Change都能调用
• 增加Application.EnableEvents = False，避免变更单元格时触发循环事件
• 处理非日期单元格，避免运行错误
• 先清空原有底色，确保颜色更新准确
• 调整日期判断顺序为从近到远，逻辑更清晰

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