excelvbatimestamp

Trying to set a date (Now) when a value is entered in a certain range


I'm trying to get a date (now) in a cell when a value is added in other cell. I'm looking to work these by Column. One gets the value and the other one should get the date. This is being applied to a Table and kind of work but when trying to add new rows to my table the macro creates new columns a applies the date to all the rows created.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim MyData As Range
    Dim MyDataRng As Range
    Set MyDataRng = ActiveSheet.ListObjects("SRFPurchases").ListColumns("Syteline/MTK Requisition").DataBodyRange
    
    
    If Intersect(Target, MyDataRng) Is Nothing Then Exit Sub
    
    On Error Resume Next
    If Target.Offset(0, 1) = "" Then
        Target.Offset(0, 1) = Now
    End If
    
    For Each MyData In MyDataRng
        If MyData = "" Then
            MyData.Offset(0, 1).ClearContents
        End If
        
    Next MyData
            
    
End Sub

Solution

  • EDIT: updated to handle >1 pair of entry/timestamp columns

    EDIT2: only add a timestamp if one doesn't already exist

    Try this out:

    Private Sub Worksheet_Change(ByVal Target As Range)
        
        Dim lc As ListColumns
        
        Set lc = Me.ListObjects("SRFPurchases").ListColumns 'the listobject columns
        
        CheckEntries Target, lc("Syteline/MTK Requisition").DataBodyRange, _
                             lc("TimeStamp").DataBodyRange
                             
                             
        CheckEntries Target, lc("Other Info").DataBodyRange, _
                             lc("TimeStamp2").DataBodyRange
        
    End Sub
    
    'If Target contains any cells in `rngEntry` then check to see if a timestamp
    '  is needed in the range `rngTimestamp`
    Sub CheckEntries(Target As Range, rngEntry As Range, rngTimestamp As Range)
        Dim c As Range, cTS As Range, rng As Range
        Set rng = Application.Intersect(Target, rngEntry) 'changes in tracked column?
        If rng Is Nothing Then Exit Sub 'no changes to track
        
        For Each c In rng.Cells      'check each tracked cell
            Set cTS = Application.Intersect(c.EntireRow, rngTimestamp) 'timestamp cell
            If Len(c.Value) > 0 Then 'any value?
                'cTS.Value = Now     'add timestamp every update
                If Len(cTS.Value) = 0 Then cTS.Value = Now 'or first entry only
            Else
                cTS.ClearContents
            End If
        Next c
    End Sub