excelvbastatictimestamp

Excel/VBA: Create a static time stamp the first time a cell is updated


I am trying to figure out a way in VBA to give a timestamp when a cell is updated, but I want that timestamp to be static and only update one time, the first time.

Columns A-I are a checklist and the user only inputs "X" as the process is being completed. Columns AH-AP are timestamp cells the correspond to the fields above.

A pairs with AH, B pairs with AI, so on and so on.

So if A2 is updated by a user, I need AH2 to have a static timestamp. If B3 is updated by a user, I need AI3 to have a static timestamp.

Currently I have VBA code that locks both the cells that users have entered "X" and the timestamp formula cells so it works but its clunky. Would much rather have a way to make these timestamp formulas into values right away VS going back periodically to change them over.

Below is in a Module, I have this code 9 times over (lockA - lockI) with the appropriate fields changed.

Sub lockA()

Application.ScreenUpdating = False

    ActiveSheet.Unprotect
    ActiveSheet.Range("$A$1:$AP$1000").AutoFilter Field:=1, Criteria1:="<>"

    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Locked = True
    Selection.FormulaHidden = False
    ActiveSheet.Range("$A$1:$AP$1000").AutoFilter Field:=1
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    
Application.ScreenUpdating = True

End Sub

Below is in my Worksheet:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:A1000")) Is Nothing Then
      Call lockA
    End If
    If Not Intersect(Target, Range("B2:B1000")) Is Nothing Then
      Call lockB
    End If
    If Not Intersect(Target, Range("C2:C1000")) Is Nothing Then
      Call lockC
    End If
    If Not Intersect(Target, Range("D2:D1000")) Is Nothing Then
      Call lockD
    End If
    If Not Intersect(Target, Range("E2:E1000")) Is Nothing Then
      Call lockE
    End If
    If Not Intersect(Target, Range("F2:F1000")) Is Nothing Then
      Call lockF
    End If
    If Not Intersect(Target, Range("G2:G1000")) Is Nothing Then
      Call lockG
    End If
    If Not Intersect(Target, Range("H2:H1000")) Is Nothing Then
      Call lockH
    End If
    If Not Intersect(Target, Range("I2:I1000")) Is Nothing Then
      Call lockI
    End If
End Sub

Updated Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
' change in target columns
If Not Intersect(Target, Range("A2:H1000")) Is Nothing Then
    Application.EnableEvents = False
    Me.Unprotect Password:="check"
    Dim c As Range: Set c = Target.Offset(0, 33) ' timestamp cell
    If IsEmpty(c.Value) Then ' If no timestamp in the cell
        c.Value = Now   ' populate cell with timestamp
        c.Locked = True ' lock cell
    End If
    Target.Locked = True    ' lock input cell
    Me.Protect Password:="check", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    Application.EnableEvents = True
End If

End Sub


Solution

  • All processing can be handled within the Change event.

    Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.CountLarge > 1 Then Exit Sub
        ' change in target columns
        If Not Intersect(Target, Range("A2:I1000")) Is Nothing Then
            Application.EnableEvents = False
            Me.Unprotect
            Dim c As Range: Set c = Target.Offset(0, 33) ' timestamp cell
            If IsEmpty(c.Value) Then ' no timestamp in the cell
                c.Value = Now   ' populate cell with timestamp
                c.Locked = True ' lock cell
            End If
            Target.Locked = True    ' lock input cell
            Me.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
            Application.EnableEvents = True
        End If
    End Sub