Worksheet_Change日期自动转换代码录入3次后异常求助

问题背景 #

需求是实现无"/"快速日期录入：输入13对应当年1月3日、22对应2月2日、310对应3月10日、1005对应10月5日、1220对应12月20日。但编写的Worksheet_Change代码存在异常：正常运行3个单元格后失效，删除列或重新加载工作簿可恢复，但仍仅能正常运行3次。异常表现为：输入13被识别为1990年1月13日、22为1990年1月22日、310为1990年第310天、1005为1899年12月31日后第1220天等。

原代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("C:C"), Target) Is Nothing Then
        If Selection.Count > 1 Then
            Exit Sub
        End If

        TLen = Len(Target)
        DaV = Target

        If TLen = 2 Then
            DaV = DateSerial(Year(Now), Left(Target, 1), Right(Target, 1))
        ElseIf TLen = 3 Then
            DaV = DateSerial(Year(Now), Left(Target, 1), Right(Target, 2))
        ElseIf TLen = 4 Then
            DaV = DateSerial(Year(Now), Left(Target, 2), Right(Target, 2))
        Else
            Exit Sub
        End If

        Application.EnableEvents = False
        Target = DaV
        Target.NumberFormat = "yyyy-mm-dd"
        Application.EnableEvents = True
    End If
End Sub

问题原因 #

1. 未处理Excel自动类型转换：当单元格被设置为日期格式后，后续输入的数字会被Excel自动解析为日期序列值，此时Len(Target)获取的是日期格式化后的字符串长度（比如"1990-01-13"长度为10），而非用户输入的原始数字长度；Left(Target,1)等函数处理的也是日期的字符串形式，而非原始输入。
2. Selection.Count判断不准确：Selection可能和Target不一致，应该直接用Target.Count判断是否为单个单元格操作。
3. 缺少错误处理：如果代码执行中出现错误，Application.EnableEvents可能无法恢复为True，导致后续事件触发失效。

修复后的代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim inputText As String
    Dim inputLen As Integer
    Dim targetDate As Date
    Dim currentYear As Integer
    
    ' 只处理C列单个单元格的修改
    If Intersect(Range("C:C"), Target) Is Nothing Or Target.Count > 1 Then
        Exit Sub
    End If
    
    ' 关闭事件触发，避免循环调用
    Application.EnableEvents = False
    
    On Error GoTo Cleanup ' 确保出错时恢复事件
    
    ' 先将单元格临时设为文本，获取原始输入内容
    Target.NumberFormat = "@"
    inputText = Trim(Target.Value)
    inputLen = Len(inputText)
    currentYear = Year(Date)
    
    ' 根据输入长度解析日期
    Select Case inputLen
        Case 2
            targetDate = DateSerial(currentYear, Left(inputText, 1), Right(inputText, 1))
        Case 3
            targetDate = DateSerial(currentYear, Left(inputText, 1), Right(inputText, 2))
        Case 4
            targetDate = DateSerial(currentYear, Left(inputText, 2), Right(inputText, 2))
        Case Else
            ' 非指定长度输入，恢复原格式并退出
            Target.NumberFormat = "yyyy-mm-dd"
            GoTo Cleanup
    End Select
    
    ' 设置日期值和格式
    Target.Value = targetDate
    Target.NumberFormat = "yyyy-mm-dd"
    
Cleanup:
    ' 恢复事件触发
    Application.EnableEvents = True
End Sub

修复说明 #

• 强制获取原始输入：先将单元格设为文本格式，确保获取到用户输入的原始数字字符串，避免Excel自动转换为日期序列。
• 准确判断操作范围：用Target.Count代替Selection.Count，确保只处理单个单元格的修改。
• 错误处理机制：添加On Error GoTo Cleanup，保证无论代码是否出错，Application.EnableEvents都会被恢复，避免事件被永久关闭。
• 明确变量类型：定义变量类型，避免隐式类型转换导致的错误。

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