Excel表格宏问题：输入值自动设当前日期，新增行时宏异常

需求：当Excel表格SRFPurchases的“Syteline/MTK Requisition”列单元格输入值时，右侧单元格自动填入当前日期；若该单元格清空，右侧日期也清除。
问题：现有宏已部分生效，但新增表格行时，宏会创建新列并给所有新增行添加日期。

原代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim MyData As Range
    Dim MyDataRng As Range
    Set MyDataRng = ActiveSheet.ListObjects("SRFPurchases").ListColumns("Syteline/MTK Requisition").DataBodyRange
    
    
    If Intersect(Target, MyDataRng) Is Nothing Then Exit Sub
    
    On Error Resume Next
    If Target.Offset(0, 1) = "" Then
        Target.Offset(0, 1) = Now
    End If
    
    For Each MyData In MyDataRng
        If MyData = "" Then
            MyData.Offset(0, 1).ClearContents
        End If
        
    Next MyData
            
    
End Sub

问题根源 #

1. 批量遍历整列：循环处理“Syteline/MTK Requisition”列的所有单元格，新增行时会批量操作所有空单元格，导致右侧日期被批量修改
2. 偏移列不稳定：用Offset(0,1)定位日期列，一旦表格新增列，偏移位置会出错，甚至误创建新列
3. 未禁用事件递归：修改日期时会再次触发Worksheet_Change事件，引发潜在的循环执行
4. 错误掩盖：On Error Resume Next会隐藏表格为空时DataBodyRange为Nothing的错误，导致逻辑异常

修正后的代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tbl As ListObject
    Dim reqCol As ListColumn
    Dim dateCol As ListColumn
    Dim targetCell As Range
    
    ' 禁用事件，避免修改日期时递归触发本宏
    Application.EnableEvents = False
    
    ' 结构化错误处理
    On Error GoTo Cleanup

    ' 定位目标表格和 requisition 列
    Set tbl = Me.ListObjects("SRFPurchases")
    Set reqCol = tbl.ListColumns("Syteline/MTK Requisition")
    
    ' 检查并创建日期列（如果不存在），可根据需求删除这段
    On Error Resume Next
    Set dateCol = tbl.ListColumns("录入日期")
    On Error GoTo Cleanup
    If dateCol Is Nothing Then
        Set dateCol = tbl.ListColumns.Add(After:=reqCol)
        dateCol.Name = "录入日期"
    End If
    
    ' 只处理用户实际修改的单元格，避免批量操作
    For Each targetCell In Intersect(Target, reqCol.DataBodyRange)
        If Not targetCell Is Nothing Then
            If targetCell.Value <> "" Then
                ' 填入当前日期+时间，若只需日期则替换成 Date()
                dateCol.DataBodyRange(targetCell.Row - tbl.HeaderRowRange.Row).Value = Now
            Else
                ' 清空对应日期单元格
                dateCol.DataBodyRange(targetCell.Row - tbl.HeaderRowRange.Row).Value = ""
            End If
        End If
    Next targetCell

Cleanup:
    ' 恢复事件触发
    Application.EnableEvents = True
    ' 错误提示（可选）
    If Err.Number <> 0 Then
        MsgBox "宏执行出错：" & Err.Description, vbExclamation
    End If
End Sub

关键改动说明 #

• 锁定日期列：通过列名“录入日期”定位目标列，替代不稳定的Offset，彻底解决新增列时的偏移错误
• 仅处理修改的单元格：只遍历用户实际改动的单元格，不再批量操作整列，解决新增行时批量添加日期的问题
• 禁用事件递归：添加Application.EnableEvents = False，避免修改日期时再次触发本宏
• 完善错误处理：替换On Error Resume Next为结构化错误处理，同时处理表格为空时的异常情况
• 可选日期格式：如果只需要日期不需要时间，把Now改成Date()即可

内容的提问来源于stack exchange，提问作者Ismael Eduardo Cortez Soto