Sheet2中VBA代码运行正常，求完善日期验证功能及提示信息

首先得说，你现有的代码基础打得很不错——双击锁定指定区域、限制日期输入的核心逻辑都跑通了！接下来咱们从提示信息友好度和代码逻辑健壮性两个角度来完善它：

一、完善提示信息，让用户更清楚该怎么做 #

你当前的提示只说了“不能输入非日期值”，用户可能会困惑：到底哪个单元格错了？正确格式是什么？可以把提示改得更具体：

MsgBox "单元格 " & cell.Address(False, False) & " 仅允许输入日期值，请输入如 ""2024/05/20"" 或 ""2024-05-20"" 格式的内容。", vbExclamation, "输入错误"

这样用户一眼就能看到出错的单元格位置，还知道正确的输入格式，体验会好很多。

二、代码逻辑的几个优化点 #

1. 处理多单元格批量修改的情况 #

你现在的代码只检查Target(1)（选中区域的第一个单元格），如果用户批量粘贴到多个单元格，其他错误的单元格不会被检测到。可以改成循环遍历每个单元格，确保每个修改的单元格都被验证。

2. 允许用户清空单元格（可选） #

如果用户删除单元格内容，IsDate会返回False，导致触发撤销操作——这可能不是你想要的。可以加个判断，只拦截非空的非日期值，给用户清空单元格的权限。

3. 完善错误处理，避免残留错误状态 #

原代码的错误处理框架已经到位，但可以加个Err.Clear，防止后续操作被之前的错误状态干扰，让代码更严谨。

优化后的完整代码 #

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("A5:D150")) Is Nothing Then
        Cancel = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim targetRange As Range
    
    ' 限定只处理A6:D150区域
    Set targetRange = Intersect(Target, Range("A6:D150"))
    If targetRange Is Nothing Then Exit Sub
    
    On Error GoTo ExitPoint
    Application.EnableEvents = False
    
    ' 遍历每个修改的单元格
    For Each cell In targetRange
        ' 允许空值，只拦截非空的非日期值
        If cell.Value <> "" And Not IsDate(cell.Value) Then
            Application.Undo
            MsgBox "单元格 " & cell.Address(False, False) & " 仅允许输入日期值，请输入如 ""2024/05/20"" 或 ""2024-05-20"" 格式的内容。", vbExclamation, "输入错误"
            GoTo ExitPoint ' 撤销后直接退出，避免重复提示
        End If
    Next cell

ExitPoint:
    Err.Clear ' 清除错误状态
    Application.EnableEvents = True
End Sub

额外小建议 #

如果想让日期输入更规范，还可以给A6:D150区域设置单元格格式为日期——这样用户输入数字时会自动转成日期，也能从视觉上提示用户这是日期输入区。

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