How to Auto Enter Date based on data Entry


My question is how do you get the initials of the user and date time stamp based on if someone changes a cell reference range (A1-J1) and then want the initials to be placed in K1 date to be stamped in column L1.




Please install the code given below in the code sheet of the worksheet on which you wish to see the action. Read the comments in the code and note that you can move the action to different columns by assigning other values to the enumeration Nws at the top of the code. Action will be taken if a change occurs between columns NwsFirstData and NwsLastData. NwsInitials has no value assigned to it. Therefore Excel will assign the value NwsInitials + 1. You can assign another value to move the column elsewhere on the same sheet.

Option Explicit

Private Enum Nws                    ' worksheet navigation
    ' 13 Nov 2018
    NwsFirstDataRow = 2             ' change as required
    NwsFirstData = 1                ' 1 = column A
    NwsLastData = 10                ' 10 = column J
End Enum

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 13 Nov 2018

    Dim Rng As Range
    Dim Rl As Long                  ' last used row

    On Error Resume Next
    ' skip if more than 1 cell was changed
    If Target.Cells.Count > 1 Then Exit Sub

    On Error GoTo 0
    Application.EnableEvents = False
    ' determine last used row in column NwsFirstData
    Rl = Cells(Rows.Count, NwsFirstData).End(xlUp).Row
    Set Rng = Range(Cells(NwsFirstDataRow, NwsFirstData), _
                    Cells(Rl + 1, NwsLastData))
    If Application.Intersect(Target, Rng) Is Nothing Then
        ' don't allow modification of time stamp
        Set Rng = Range(Cells(NwsFirstDataRow, NwsTime), _
                        Cells(Rl, NwsTime))
        If Not Application.Intersect(Target, Rng) Is Nothing Then _
        With Target
            Cells(.Row, NwsInitials).Value = UserInitials
            With Cells(.Row, NwsTime)
                .Value = Now()
                ' modify the time stampe format to preference
                .NumberFormat = "dd/mm/yy hh:mm:ss"
            End With
        End With
    End If
    Application.EnableEvents = True
End Sub

Private Function UserInitials() As String
    ' 13 Nov 2018

    Dim Fun As String
    Dim Sp() As String
    Dim i As Long

    Sp = Split(UCase(Application.UserName))
    If Len(Join(Sp)) Then
        Fun = Left(Sp(LBound(Sp)), 1)
        If UBound(Sp) Then Fun = Fun & Left(Sp(UBound(Sp)), 1)
    End If
    UserInitials = Fun
End Function

The enumeration NwsFirstDataRow has a value of 2 which has the effect of taking no action if a change is made in row 1 which would usually hold captions. If you really want to record changes to row 1 change the value in the code: NwsFirstDataRow = 1.

The code prevents modification of the time stamp, undoing any change the user might make without notice, but permits changing the user initials. If you don't like that modify the code as follows.

Change this specification

Set Rng = Range(Cells(NwsFirstDataRow, NwsTime), _
                        Cells(Rl, NwsTime))

into this specification

Set Rng = Range(Cells(NwsFirstDataRow, NwsInitials), _
                        Cells(Rl, NwsTime))

If you make this change the columns NwsInitials and NwsTime must be adjacent to each other.

The system is implemented in the attached workbook. Observe that the workbook must be saved as macro-enabled (xlsm format) because it contains code.


Answer the Question

You must create an account to use the forum. Create an Account or Login