CODEWITHSUNDEEP
excelvba
Yogurt
Yogurt

Reputation: 93

Update/Time stamp into cell when value change

I have this VBA code to change or to update the time stamp for 2 cells at the same row in Excel, but some how I can only have the first column to update the time stamp when I change the value but nothing happen to the second column, it return blank value. I also want to have the sheet protected so when the time stamp is update, it is locked and not be edit but dont know how to put it into protection

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

Upvotes: 3

Views: 885

Answers (2)

VBasic2008
VBasic2008

Reputation: 54807

Add Time Stamp When Cell Changes

  • Adjust the values in the constants section (the password (PW)).

The Code

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

Upvotes: 2

Gary's Student
Gary's Student

Reputation: 96753

How about:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Range, L As Range, T As Range
    Dim rw As Long, v As String
    
    Set I = Range("I:I")
    Set L = Range("L:L")
    Set T = Target
    rw = T.Row
    v = T.Value
    
    If Not Intersect(T, I) Is Nothing Then
        If v = "Yes" Then
            Application.EnableEvents = False
                Range("J" & rw) = Now
            Application.EnableEvents = True
        End If
    End If
    
    If Not Intersect(T, L) Is Nothing Then
        If v = "Complete" Then
            Application.EnableEvents = False
                Range("M" & rw) = Now
            Application.EnableEvents = True
        End If
    End If
End Sub

EDIT#1:

This version of the code will not over-write a timestanp after it has been entered.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Range, L As Range, M As Range
    Dim rw As Long, v As String
    
    Set I = Range("I:I")
    Set L = Range("L:L")
    Set T = Target
    rw = T.Row
    v = T.Value
    
    If Not Intersect(T, I) Is Nothing Then
        If v = "Yes" And Range("J" & rw) = "" Then
            Application.EnableEvents = False
                Range("J" & rw) = Now
            Application.EnableEvents = True
        End If
    End If
    
    If Not Intersect(T, L) Is Nothing Then
        If v = "Complete" And Range("M" & rw) = "" Then
            Application.EnableEvents = False
                Range("M" & rw) = Now
            Application.EnableEvents = True
        End If
    End If
End Sub

The code won't change a timestamp, but you still can.

Upvotes: 2

Related Questions