如何在输入无效值时退出Excel单元格编辑且不修改内容？

问题背景 #

通过两个宏实现以下功能：

• 允许同一单元格输入多个逗号分隔的日期
• 仅接受2000年1月1日至当日、格式为DD/MM/YYYY的日期

但输入无效值（如未来日期）时，点击错误提示框的「Cancel」偶尔会清空单元格内所有正确内容，且无法撤销。需要实现：输入无效值时退出编辑，保留单元格原有内容。

现有宏代码 #

宏1：多日期输入处理 #

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

' Written by Philip Treacy
    Dim OldVal As String
    Dim NewVal As String
    
    ' 跳过多单元格修改
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    
    If Not Intersect(Target, ActiveSheet.Range("Date_Entry")) Is Nothing Then
    
        ' 关闭事件触发，避免循环执行
        Application.EnableEvents = False
        
        NewVal = Target.Value
        
        ' 执行撤销获取旧值
        On Error Resume Next
        Application.Undo
        On Error GoTo 0
        
        OldVal = Target.Value
        
        ' 若新值已存在则移除
        If InStr(OldVal, NewVal) Then
        
            If InStr(OldVal, ",") Then
            
                If InStr(OldVal, ", " & NewVal) Then
                    Target.Value = Replace(OldVal, ", " & NewVal, "")
                Else
                    Target.Value = Replace(OldVal, NewVal & ", ", "")
                End If
                
            Else
                Target.Value = ""
            End If
        
        Else
        
            If OldVal = "" Then
                Target.Value = NewVal
            Else
                If NewVal = "" Then
                    Target.Value = ""
                Else
                    ' 避免重复添加同一日期
                    If InStr(Target.Value, NewVal) = 0 Then
                        Target.Value = OldVal & ", " & NewVal
                    End If
                End If
            End If
            
        End If
        
        Application.EnableEvents = True
            
    Else
        Exit Sub
    End If

End Sub

宏2：日期数据验证 #

Sub customised_validation_dates()

With ActiveSheet.Range("Date_Entry").Validation
    .Delete
    .Add Type:=xlValidateDate, AlertStyle:=xlValidAlertStop, _
     Operator:=xlBetween, Formula1:="01/01/2000", Formula2:="=TODAY()"
    .IgnoreBlank = True
    .ErrorTitle = "Invalid Date"
    .ErrorMessage = "Input must be date between 01/01/2000 and today. Date must also be entered in DD/MM/YYYY format."
    .ShowInput = True
    .ShowError = True
End With

End Sub

解决方案 #

问题根源在于原Worksheet_Change事件中Application.Undo的逻辑与数据验证的xlValidAlertStop样式冲突，导致Cancel操作偶尔丢失旧值。以下是优化后的代码：

1. 优化数据验证宏 #

改用自定义公式实现多日期逐个校验，同时调整提示样式确保Cancel时保留原有内容：

Sub customised_validation_dates()
    With ActiveSheet.Range("Date_Entry").Validation
        .Delete
        ' 自定义公式校验每个逗号分隔的日期
        .Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertRetry, _
             Formula1:="=AND(ISNUMBER(DATEVALUE(SUBSTITUTE(TRIM(MID(SUBSTITUTE(A1,"","",REPT(" ",255)),(ROW(INDIRECT("1:"&LEN(A1)-LEN(SUBSTITUTE(A1,"",""))+1))-1)*255+1,255)),""/"",""-""))),DATEVALUE(SUBSTITUTE(TRIM(MID(SUBSTITUTE(A1,"","",REPT(" ",255)),(ROW(INDIRECT("1:"&LEN(A1)-LEN(SUBSTITUTE(A1,"",""))+1))-1)*255+1,255)),""/"",""-""))>=DATE(2000,1,1),DATEVALUE(SUBSTITUTE(TRIM(MID(SUBSTITUTE(A1,"","",REPT(" ",255)),(ROW(INDIRECT("1:"&LEN(A1)-LEN(SUBSTITUTE(A1,"",""))+1))-1)*255+1,255)),""/"",""-""))<=TODAY())"
        .IgnoreBlank = True
        .ErrorTitle = "无效日期"
        .ErrorMessage = "请输入2000年1月1日至今日之间的日期，格式为DD/MM/YYYY，多个日期用逗号分隔。"
        .ShowInput = True
        .ShowError = True
    End With
End Sub

2. 重写Worksheet_Change事件 #

添加预校验逻辑，提前保存原始值，验证失败直接恢复：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim OldVal As String
    Dim NewVal As String
    Dim DateParts As Variant
    Dim i As Integer
    Dim isValidDate As Boolean
    Dim tempDate As Date
    
    ' 跳过多单元格修改或空值
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    If Intersect(Target, ActiveSheet.Range("Date_Entry")) Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    On Error GoTo ErrorHandler
    
    ' 提前保存原始值
    OldVal = Target.Value
    NewVal = Target.Value
    
    ' 拆分日期并逐个验证
    DateParts = Split(NewVal, ",")
    isValidDate = True
    
    For i = LBound(DateParts) To UBound(DateParts)
        DateParts(i) = Trim(DateParts(i))
        ' 强制按DD/MM/YYYY解析日期
        On Error Resume Next
        tempDate = DateSerial(Mid(DateParts(i), 4, 4), Mid(DateParts(i), 1, 2), Mid(DateParts(i), 7, 2))
        On Error GoTo ErrorHandler
        
        If Err.Number <> 0 Or tempDate < Date(2000, 1, 1) Or tempDate > Date Then
            isValidDate = False
            Exit For
        End If
    Next i
    
    ' 验证失败则恢复原始值
    If Not isValidDate Then
        MsgBox "输入包含无效日期，请检查格式（DD/MM/YYYY）和范围（2000-01-01至今日）。", vbExclamation, "无效日期"
        Target.Value = OldVal
        GoTo Cleanup
    End If
    
    ' 处理重复日期（可选保留）
    If InStr(OldVal, NewVal) > 0 Then
        If InStr(OldVal, ", " & NewVal) > 0 Then
            Target.Value = Replace(OldVal, ", " & NewVal, "")
        ElseIf InStr(OldVal, NewVal & ", ") > 0 Then
            Target.Value = Replace(OldVal, NewVal & ", ", "")
        Else
            Target.Value = ""
        End If
    Else
        If OldVal = "" Then
            Target.Value = NewVal
        Else
            If InStr(Target.Value, NewVal) = 0 Then
                Target.Value = OldVal & ", " & NewVal
            End If
        End If
    End If
    
Cleanup:
    Application.EnableEvents = True
    Exit Sub
    
ErrorHandler:
    MsgBox "处理日期时发生错误，请重试。", vbCritical, "错误"
    Target.Value = OldVal
    Application.EnableEvents = True
End Sub

关键改进点 #

• 数据验证改用自定义公式，支持对逗号分隔的每个日期单独校验
• Worksheet_Change事件提前保存原始值，验证失败直接恢复，避免Undo操作导致的内容丢失
• 强制按DD/MM/YYYY格式解析日期，避免区域格式差异影响验证结果
• 完善错误处理分支，确保事件始终重新启用，避免后续操作失效

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