Add more than 1 timestamp on one Excel Worksheet

user_19158379 0
Viewed 58

I have some issue...

I have a work sheet to track CRM pipeline activities and every status changed will be recorded by a time stamp... but, I don't know how to make more than one time stamp...

Here the condition:

  • Cell "A" will be as Range and Trigger, Then Cell "B" will be as target timestamp I.

  • Cell "G" will be as Range and Trigger, Then Cell "H" will be as target timestamp II.

  • Cell "P" will be as Range and Trigger, Then Cell "Q" will be as target timestamp III.

  • Cell "AA" will be as Range and Trigger, Then Cell "AB" will be as target timestamp IV.

  • The Range and Trigger Values can be as number and/or text.

This my Worksheet Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myTableRange1 As Range
Dim myTrigger1 As Range
Dim myUpdatedRange1 As Range

'Your data table range
Set myTableRange1 = Range("B6:B50000")

'Check if the changed cell is in the data tabe or not.
If Intersect(Target, myTableRange1) Is Nothing Then Exit Sub

'Stop events from running
Application.EnableEvents = False

'Column for the date/time
Set myTrigger1 = Range("B" & Target.Row)

'Column for last updated date/time
Set myUpdatedRange1 = Range("G" & Target.Row)

'Determine if the input date/time should change
If myTrigger1.Value = "" Then

myUpdatedRange1.Value = Now   

End If

'Update the updated date/time value
myUpdatedRange1.Value = Now

'Turn events back on
Application.EnableEvents = True
End Sub
timestamp vba excel
1 Answers

A Worksheet Change: Multiple Timestamp Columns

  • This will add a timestamp only if the 'timestamp cell' is blank.
Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const FirstRow As Long = 6
    Const ColumnsRangeAddress As String = "A:A,G:G,P:P,AA:AA"
    
    Dim srg As Range: Set srg = Intersect(Rows(FirstRow) _
        .Resize(Rows.Count - FirstRow + 1), Range(ColumnsRangeAddress))
    
    Dim irg As Range: Set irg = Intersect(srg, Target)
    If irg Is Nothing Then Exit Sub
    
    Dim drg As Range
    Dim iCell As Range
    
    For Each iCell In irg.Cells ' 'A,G,P,AA'
        With iCell.Offset(, 1) ' 'B,H,Q,AB'
            If Len(CStr(.Value)) = 0 Then ' is blank
                If drg Is Nothing Then
                    Set drg = .Cells
                Else
                    Set drg = Union(drg, .Cells)
                End If
            'Else ' is not blank; do nothing
            End If
        End With
    Next iCell
    
    If drg Is Nothing Then Exit Sub
    
    Application.EnableEvents = False ' before writing
    drg.Value = Now
    Application.EnableEvents = True ' after writing

End Sub
user_98140690
Related