Auto date fill in in Excel file

Question

Can someone please help me with this code. It will insert the current date in H if I do any changes to I. My problem is that this will not work if for example I fill in I1 with something, and then I drag down for copying in many cells at once. If for example I copy value from I1 once at a time in each cell( I2,I3 ETC) it will work.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
    Dim xRg As Range, xCell As Range
    On Error Resume Next
    If (Target.Count = 1) Then
        If (Not Application.Intersect(Target, Me.Range("I:I")) Is Nothing) Then _
            Target.Offset(0, -1) = Date
        Application.EnableEvents = False
        Set xRg = Application.Intersect(Target.Dependents, Me.Range("I:I10"))
        If (Not xRg Is Nothing) Then
            For Each xCell In xRg
                xCell.Offset(0, -1) = Date
            Next
        End If
        Application.EnableEvents = True
    End If
End Sub

Thank you !

Siddharth Rout · Accepted Answer · 2021-01-08T07:22:20.247

Avoid the unnecessary use of On Error Resume Next. Handle the Error gracefully. I recommend reading THIS once when using Worksheet_Change

Also you have If (Target.Count = 1) Then because of which your code doesn't execute. When you drag, the count increases.

Is this what you are trying?

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Whoa
    Dim aCell As Range
    
    Application.EnableEvents = False
    
    If Not Intersect(Target, Range("I:I")) Is Nothing Then
        For Each aCell In Target
            '~~> Additional blank check for I. So that the date
            '~~> is not inserted if the value is deleted. Remove this
            '~~> if you want the date to be inserted even when the value is deleted
            If Len(Trim(aCell.Value)) <> 0 Then
                Range("H" & aCell.Row).Value = Date
            Else
                'Remove Date?
            End If
        Next aCell
    End If
    
Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

In action:

Auto date fill in in Excel file

1 Answers1