excel - 值更改时更新/时间戳到单元格中

Question

我有这个 VBA 代码来更改或更新 Excel 中同一行的 2 个单元格的时间戳，但是有些方法我只能在第一列更新时间戳当我更改值但没有发生第二列，它返回空白值。我也想保护工作表，所以当时间戳更新时，它被锁定并且无法编辑但不知道如何将其置于保护状态

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range
On Error Resume Next


Dim I As Range, J As Range, L As Range, M As Range
Set I = Range("I:I")
Set L = Range("L:L")

Set T = Target

' Timestamp for Trackin
If Intersect(I, T) Is Nothing Then Exit Sub
If Intersect(I, T).Value = "Yes" Then Range("J" & T.Row).Value = Now

' Timestamp for Completion
If Intersect(L, T) Is Nothing Then Exit Sub
If Intersect(L, T).Value = "Complete" Then Range("M" & T.Row).Value = Now

Application.EnableEvents = True

End Sub

Answer 1

单元格变化时添加时间戳

• 调整常量部分的值(密码(PW))。

代码

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const cCheckList As String = "I,L"
    Const cWriteList As String = "J,M"
    Const CriteriaList As String = "Yes,Complete"
    Const PW As String = ""
    Const FirstRow As Long = 2
    
    Dim cCheck() As String: cCheck = Split(cCheckList, ",")
    Dim cWrite() As String: cWrite = Split(cWriteList, ",")
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    
    Dim rng As Range
    Dim ColOffset As Long
    Dim n As Long
    
    For n = 0 To UBound(cCheck)
        Set rng = Intersect(Columns(cCheck(n)) _
            .Resize(Rows.Count - FirstRow + 1).Offset(FirstRow - 1), Target)
        If Not rng Is Nothing Then
            ColOffset = Columns(cWrite(n)).Column - Columns(cCheck(n)).Column
            Application.ScreenUpdating = False
            Application.EnableEvents = False
            Me.Unprotect Password:=PW
            updateLock rng, Criteria(n), ColOffset, Now
            Me.Protect Password:=PW
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    Next n

End Sub

Sub updateLock( _
        rng As Range, _
        ByVal s As String, _
        ByVal ColOffset As Long, _
        ByVal TimeStamp As Date)
    
    Const ProcName As String = "updateLock"
    On Error GoTo clearError

    Dim aRng As Range
    Dim cel As Range
    For Each aRng In rng.Areas
        For Each cel In aRng.Cells
            If Not IsError(cel) Then
                With cel
                    If StrComp(.Value, s, vbTextCompare) = 0 Then
                        If Not StrComp(.Value, s, vbBinaryCompare) = 0 Then
                            .Value = s
                        End If
                        .Locked = True
                        With .Offset(, ColOffset)
                            .Value = TimeStamp
                            '.Locked = True
                        End With
                    End If
                End With
            End If
        Next cel
    Next aRng

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Sub

Sub doEnableEvents()
    Application.EnableEvents = True
End Sub