Excel 如何将行创建日期和更新日期（行中任何单元格的）自动存储到单独的单元格中？

我试图在Excel工作表上创建VBA代码，在该工作表中，我可以自动插入创建日期（一旦数据插入行中）和更新日期（一旦行中的任何单元格值与以前的值发生更改）。 我尝试了下面的代码，我可以得到创建日期，但不能得到更新日期

我得到这个错误

类型不匹配

在线：

If Cells(Target.Row, i).Value <> PrevVal(Target.Row, i) Then

---

Dim preval作为变量
专用子工作表\u选择更改（ByVal目标作为范围）
错误转到快速退出
如果Selection.Rows.Count=1和Selection.Columns.Count=1，则
PrevVal=选择值
其他的
PrevVal=选择
如果结束
现有：
端接头
私有子工作表_更改（ByVal目标作为范围）
如果不相交（范围（“B:B”），则目标）是否为零
相交（范围（“C:C”）、目标）则什么都不是
单元格（Target.Row，1）。值=单元格（Target.Row，2）和单元格（Target.Row，3）
如果单元格（Target.Row，4）.Value=”“，则
单元格（Target.Row，4）。值=日期和时间
单元格（Target.Row，4）.NumberFormat=“m/d/yyyy h:mm AM/PM”
如果结束
如果结束
作为整数的Dim i
如果Target.Rows.Count=1和Target.Columns.Count=1，则
对于i=2到50
如果单元格（Target.Row，i）.Value PrevVal（Target.Row，i），则
单元格（Target.Row，5）。值=日期和时间
单元格（Target.Row，5）.NumberFormat=“m/d/yyyy h:mm AM/PM”
如果结束
接下来我
如果结束
端接头

我终于纠正了我的代码，现在它运行良好

Dim PrevVal As Variant

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    On Error GoTo ExitGraceFully
    If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
        PrevVal = Target.Value
    Else
        PrevVal = Target
    End If
ExitGraceFully:
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("B:C"), Target) Is Nothing Then

    Cells(Target.Row, 1).Value = Cells(Target.Row, 2) & Cells(Target.Row, 3)

If Cells(Target.Row, 4).Value = "" Then
Cells(Target.Row, 4).Value = Date & " " & Time
Cells(Target.Row, 4).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
End If


If Not Intersect(Range("F:Z"), Target) Is Nothing Then
Application.EnableEvents = False
If (PrevVal <> "") And (Cells(Target.Row, Target.Column).Value <> PrevVal) Then
Cells(Target.Row, 5).Value = Date & " " & Time
Cells(Target.Row, 5).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If

End If
Application.EnableEvents = True

End Sub

Dim preval作为变量
专用子工作表\u选择更改（ByVal目标作为范围）
错误转到快速退出
如果Selection.Rows.Count=1和Selection.Columns.Count=1，则
PrevVal=目标值
其他的
PrevVal=目标
如果结束
现有：
端接头
私有子工作表_更改（ByVal目标作为范围）
如果不相交（范围（“B:C”），目标）则为零
单元格（Target.Row，1）。值=单元格（Target.Row，2）和单元格（Target.Row，3）
如果单元格（Target.Row，4）.Value=”“，则
单元格（Target.Row，4）。值=日期和时间
单元格（Target.Row，4）.NumberFormat=“m/d/yyyy h:mm AM/PM”
如果结束
如果结束
如果不相交（范围（“F:Z”），目标）则为零
Application.EnableEvents=False
如果（PrevVal“”）和（单元格（Target.Row，Target.Column）.Value PrevVal），则
单元格（Target.Row，5）。值=日期和时间
单元格（Target.Row，5）.NumberFormat=“m/d/yyyy h:mm AM/PM”
如果结束
如果结束
Application.EnableEvents=True
端接头

我终于纠正了我的代码，现在它运行良好

Dim PrevVal As Variant

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    On Error GoTo ExitGraceFully
    If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
        PrevVal = Target.Value
    Else
        PrevVal = Target
    End If
ExitGraceFully:
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("B:C"), Target) Is Nothing Then

    Cells(Target.Row, 1).Value = Cells(Target.Row, 2) & Cells(Target.Row, 3)

If Cells(Target.Row, 4).Value = "" Then
Cells(Target.Row, 4).Value = Date & " " & Time
Cells(Target.Row, 4).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
End If


If Not Intersect(Range("F:Z"), Target) Is Nothing Then
Application.EnableEvents = False
If (PrevVal <> "") And (Cells(Target.Row, Target.Column).Value <> PrevVal) Then
Cells(Target.Row, 5).Value = Date & " " & Time
Cells(Target.Row, 5).NumberFormat = "m/d/yyyy h:mm AM/PM"
End If

End If
Application.EnableEvents = True

End Sub

Dim preval作为变量
专用子工作表\u选择更改（ByVal目标作为范围）
错误转到快速退出
如果Selection.Rows.Count=1和Selection.Columns.Count=1，则
PrevVal=目标值
其他的
PrevVal=目标
如果结束
现有：
端接头
私有子工作表_更改（ByVal目标作为范围）
如果不相交（范围（“B:C”），目标）则为零
单元格（Target.Row，1）。值=单元格（Target.Row，2）和单元格（Target.Row，3）
如果单元格（Target.Row，4）.Value=”“，则
单元格（Target.Row，4）。值=日期和时间
单元格（Target.Row，4）.NumberFormat=“m/d/yyyy h:mm AM/PM”
如果结束
如果结束
如果不相交（范围（“F:Z”），目标）则为零
Application.EnableEvents=False
如果（PrevVal“”）和（单元格（Target.Row，Target.Column）.Value PrevVal），则
单元格（Target.Row，5）。值=日期和时间
单元格（Target.Row，5）.NumberFormat=“m/d/yyyy h:mm AM/PM”
如果结束
如果结束
Application.EnableEvents=True
端接头

非常感谢@userZZZ，这正是我想要的！ 我根据我的要求修改了您的代码，并添加了另一个约束，以更改删除单元格内容的日期。我注意到该代码只适用于单个单元格，而不适用于多个单元格。我可能会在某个时候做这件事，但现在这已经足够了

编辑：我添加了一次操作多个单元格并更新所有相应行的日期的可能性。但是，它仍然不适用于多个单元格的复制/粘贴。为此，我添加了一条错误消息。或者，只需在第一个函数的开头添加“Application.CutCopyMode=False”即可停用复制/粘贴模式

    Dim PrevVal As Variant
    Dim Block_rows As Integer
    Dim Date_column As Integer

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)

        On Error GoTo ExitGracefully

        If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
            PrevVal = Target.Value
        Else
            PrevVal = Target
        End If
    ExitGracefully:
    End Sub

    Private Sub Worksheet_Change(ByVal Target As Range)
        Date_column = 9
        Block_rows = 8

        On Error GoTo ErrorMessage

        'Select and change single cell
        If Not Intersect(Range("A:H"), Target) Is Nothing And Target.Row > Block_rows Then
            Application.EnableEvents = False
            If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
                'Update date if value changes or is deleted
                If (Cells(Target.Row, Target.Column).Value <> PrevVal) Or _
                (Cells(Target.Row, Target.Column).Value = 0 And PrevVal <> 0) Then
                    Cells(Target.Row, Date_column).Value = Date
                    Cells(Target.Row, Date_column).NumberFormat = "dd-mmm-yyyy"
                End If

            'Select multiple cells, but only change single cells
            ElseIf (Cells(Target.Row, Target.Column).Value <> PrevVal(Target.Row - Selection.Row + 1, Target.Column - Selection.Column + 1)) And _
            (Cells(Target.Row, Target.Column).Value <> 0) Then
                Cells(Target.Row, Date_column).Value = Date
                Cells(Target.Row, Date_column).NumberFormat = "dd-mmm-yyyy"

            'Delete multiple cells at once
            Else
                For RCount = 0 To Target.Rows.Count - 1
                    For CCount = 0 To Target.Columns.Count - 1
                        'Blank rows
                        If (Cells(Target.Row + RCount, Target.Column).Value = 0 And PrevVal(RCount + 1, CCount + 1) = 0) Then

                        'Delete cells or rows
                        ElseIf (Cells(Target.Row + RCount, Target.Column).Value = 0 And PrevVal(RCount + 1, CCount + 1) <> 0) Then
                            Cells(Target.Row + RCount, Date_column).Value = Date
                            Cells(Target.Row + RCount, Date_column).NumberFormat = "dd-mmm-yyyy"
                        End If
                    Next CCount
                Next RCount
            End If
        End If

        Application.EnableEvents = True
        Exit Sub

    ErrorMessage:
        MsgBox ("This function is not supported for the automatic update of the date.")
        Resume Next

    End Sub

Dim preval作为变量
将块_行设置为整数
Dim Date_列为整数
专用子工作表\u选择更改（ByVal目标作为范围）
错误转到快速退出
如果Selection.Rows.Count=1和Selection.Columns.Count=1，则
PrevVal=目标值
其他的
PrevVal=目标
如果结束
现有：
端接头
私有子工作表_更改（ByVal目标作为范围）
日期列=9
块_行=8
关于错误转到错误消息
'选择并更改单个单元格
如果不相交（范围（“A:H”），则目标）为Nothing和Target.Row>Block_行，然后
Application.EnableEvents=False
如果Selection.Rows.Count=1和Selection.Columns.Count=1，则
'值更改或删除时更新日期
If（单元格（Target.Row，Target.Column）.Value PrevVal）或_
（单元格（Target.Row，Target.Column）.Value=0和PrevVal 0）然后
单元格（Target.Row，Date\u列）。值=日期
单元格（Target.Row，Date\u列）。NumberFormat=“dd mmm yyyy”
如果结束
'选择多个单元格，但仅更改单个单元格
ElseIf（单元格（Target.Row，Target.Column）.Value PrevVal（Target.Row-Selection.Row+1，Target.Column-Selection.Column+1））和_
（单元格（Target.Row，Target.Column）.Value 0）然后
单元格（Target.Row，Date\u列）。值=日期
单元格（Target.Row，Date\u列）。NumberFormat=“dd mmm yyyy”
    Dim PrevVal As Variant
    Dim Block_rows As Integer
    Dim Date_column As Integer

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)

        On Error GoTo ExitGracefully

        If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
            PrevVal = Target.Value
        Else
            PrevVal = Target
        End If
    ExitGracefully:
    End Sub

    Private Sub Worksheet_Change(ByVal Target As Range)
        Date_column = 9
        Block_rows = 8

        On Error GoTo ErrorMessage

        'Select and change single cell
        If Not Intersect(Range("A:H"), Target) Is Nothing And Target.Row > Block_rows Then
            Application.EnableEvents = False
            If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
                'Update date if value changes or is deleted
                If (Cells(Target.Row, Target.Column).Value <> PrevVal) Or _
                (Cells(Target.Row, Target.Column).Value = 0 And PrevVal <> 0) Then
                    Cells(Target.Row, Date_column).Value = Date
                    Cells(Target.Row, Date_column).NumberFormat = "dd-mmm-yyyy"
                End If

            'Select multiple cells, but only change single cells
            ElseIf (Cells(Target.Row, Target.Column).Value <> PrevVal(Target.Row - Selection.Row + 1, Target.Column - Selection.Column + 1)) And _
            (Cells(Target.Row, Target.Column).Value <> 0) Then
                Cells(Target.Row, Date_column).Value = Date
                Cells(Target.Row, Date_column).NumberFormat = "dd-mmm-yyyy"

            'Delete multiple cells at once
            Else
                For RCount = 0 To Target.Rows.Count - 1
                    For CCount = 0 To Target.Columns.Count - 1
                        'Blank rows
                        If (Cells(Target.Row + RCount, Target.Column).Value = 0 And PrevVal(RCount + 1, CCount + 1) = 0) Then

                        'Delete cells or rows
                        ElseIf (Cells(Target.Row + RCount, Target.Column).Value = 0 And PrevVal(RCount + 1, CCount + 1) <> 0) Then
                            Cells(Target.Row + RCount, Date_column).Value = Date
                            Cells(Target.Row + RCount, Date_column).NumberFormat = "dd-mmm-yyyy"
                        End If
                    Next CCount
                Next RCount
            End If
        End If

        Application.EnableEvents = True
        Exit Sub

    ErrorMessage:
        MsgBox ("This function is not supported for the automatic update of the date.")
        Resume Next

    End Sub