Excel VBA实现单元格新输日期时旧日期加删除线及日期差标色

需求1：E-H列输入第二个日期自动给旧日期加删除线 #

该效果需要通过工作表Change事件实现，捕捉单元格输入动作自动处理格式，操作步骤如下：

1. 打开需要生效的工作簿，按Alt+F11调出VBA编辑器
2. 在左侧工程资源管理器中双击目标工作表，打开工作表代码模块
3. 将以下代码粘贴到模块中，保存即可生效

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oldVal As Variant, newVal As Variant
    Dim oldDateLen As Long
    
    ' 批量修改、非E-H列、空单元格均不触发处理
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Me.Range("E:H")) Is Nothing Then Exit Sub
    If IsEmpty(Target.Value) Then Exit Sub
    
    Application.EnableEvents = False
    newVal = Target.Value
    
    ' 读取修改前的单元格原值
    Application.Undo
    oldVal = Target.Value
    
    ' 仅在原值、新值均为日期，且单元格未存过双日期时执行格式处理
    If IsDate(oldVal) And IsDate(newVal) And InStr(1, Target.Text, vbNewLine) = 0 Then
        Target.Value = CStr(oldVal) & vbNewLine & CStr(newVal)
        oldDateLen = Len(CStr(oldVal))
        ' 旧日期加删除线，新日期保留常规格式
        Target.Characters(1, oldDateLen).Font.Strikethrough = True
        Target.Characters(oldDateLen + 1, Len(CStr(newVal)) + 1).Font.Strikethrough = False
    Else
        ' 不符合双日期规则时恢复用户输入内容
        Target.Value = newVal
    End If

ErrHandler:
    Application.EnableEvents = True
End Sub

说明：该逻辑仅在单元格第一次追加第二个日期时触发，已有双日期的单元格再次修改不会重复加格式，避免格式混乱。

需求2：扩展日期差标色逻辑 #

原代码存在循环未闭合、逻辑重复冗余、未适配双日期单元格的问题，优化后代码可一次性覆盖E-H列的标色判断，同时兼容需求1的双日期格式：

1. 在VBA编辑器中右键点击工程名，选择「插入」-「模块」
2. 将以下代码粘贴到新建的标准模块中，需要刷新标色时直接运行宏ColorMeElmo即可

Sub ColorMeElmo()
    Dim lastRow As Long, i As Long, col As Long
    Dim baseDate As Date, targetDate As Date
    Dim dateDiff As Long, cellVal As String
    
    ' 取D列最后一行数据行号
    lastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
    
    ' 逐行遍历数据
    For i = 2 To lastRow
        ' 跳过D列无有效日期的行
        If Not IsDate(Range("D" & i).Value) Then GoTo NextRow
        baseDate = CDate(Range("D" & i).Value)
        
        ' 遍历E到H列（列号5-8）
        For col = 5 To 8
            cellVal = Trim(Cells(i, col).Text)
            ' 空单元格清除填充色
            If cellVal = "" Then
                Cells(i, col).Interior.ColorIndex = xlNone
                GoTo NextCol
            End If
            
            ' 适配双日期格式：存在换行时取最后一个最新输入的日期计算
            If InStr(1, cellVal, vbNewLine) > 0 Then
                targetDate = CDate(Split(cellVal, vbNewLine)(UBound(Split(cellVal, vbNewLine))))
            ElseIf IsDate(cellVal) Then
                targetDate = CDate(cellVal)
            Else
                ' 非日期内容清除填充
                Cells(i, col).Interior.ColorIndex = xlNone
                GoTo NextCol
            End If
            
            ' 按日期间隔标色
            dateDiff = DateDiff("D", targetDate, baseDate)
            Cells(i, col).Interior.Color = IIf(dateDiff <= 5, vbRed, vbYellow)
NextCol:
        Next col
NextRow:
    Next i
End Sub

使用注意事项 #

• 包含VBA代码的工作簿需要保存为.xlsm格式，启用宏后代码才能正常运行
• 如果需要打开文件自动刷新标色，可以把Call ColorMeElmo语句加到工作表的Activate事件中

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