Update date cell for each cell change-CodePudding

I am trying to automate a date of response column in excel from various user. I had updated the code basis some R&D from various blogs, but is stuck on one place. My code is given below. Same is able to record the date of change of a cell in next cell. And as I want only date of first update, it is doing fine. However, in case if user is removing the response, date is still there and thus "Target.Offset(0, 1).ClearContents" is not working. Kindly help to update the code.

My Requirement from the code as summarized as below:

It should update date of change of cell in next cell (Offset (0,1))
In case of multiple change of a cell, it only record first response date and should not overwrite previous date.
when a user delete the response, date should also be removed. (Code will run in excel having approx. 2000 rows and approx. 10-20 of user will access the sheet.)

Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If Not Intersect(Target, Application.ActiveSheet.Range("U:U,W:W,Y:Y,AA:AA,AC:AC,AE:AE,AG:AG,AI:AI")) Is Nothing Then
Application.EnableEvents = False
For Each xCell In xRg
        If VBA.IsEmpty(xCell.Value) Then
            If Target.Offset(0, 1) = "" Then
            Target.Offset(0, 1) = Now
            End If
            Else
            Target.Offset(0, 1).ClearContents
        End If
    Next
    Application.EnableEvents = True
End If
End If
End Sub

CodePudding user response：

I think you're after this

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
        
    Dim xRg As Range
        Set xRg = Intersect(Target, Range("U:U,W:W,Y:Y,AA:AA,AC:AC,AE:AE,AG:AG,AI:AI")) ' set the range of possible interest
        
        If Not xRg Is Nothing Then ' if changed range crosses the one of interest
        
            On Error GoTo SafeExit
            Application.EnableEvents = False
            
            Dim xCell As Range
            For Each xCell In xRg ' loop through the changed range of interest
                Select Case True
                
                    Case VBA.IsEmpty(xCell.Value) ' if current cell is empty
                        xCell.Offset(0, 1).ClearContents ' delete the date
                    
                    Case VBA.IsEmpty(xCell.Offset(0, 1).Value) ' if no date next
                        xCell.Offset(0, 1).Value = Now 'write the date
                    
                End Select
            Next
                
        End If

SafeExit:
    Application.EnableEvents = True

End Sub

Some assumptions/comments:

handling the case of multiple cells change
On Error Resume Next was of no use use On Error GoTo SomeLabel, instead, and be sure to restore Application.EnableEvents = True in case of any error
For Each xCell In xRg in your code was assuming to loop through a range (xRg) that hadn't been set, yet

CodePudding user response：

You didn't set xRg.

Due to On error resume next you don't receive an error.

Refactoring idea: Put the code in a single Sub passing the target range

reading the name of the sub makes clear what it is doing
you could re-use it from other sheets

I would update the code like this:

Private Sub Worksheet_Change(ByVal Target As Range)

'On Error Resume Next       'don't use this - you won't be able to fix errors

setChangeDate Target
            
End Sub

You can put this in a normal module - or keep it in the worksheet module.

Public Sub setChangeDate(rgChanged As Range)

Dim wsToCheck As Worksheet
Set wsToCheck = rgChanged.Parent

Dim rgToCheck As Range
Set rgToCheck = wsToCheck.Range("U:U,W:W,Y:Y,AA:AA,AC:AC,AE:AE,AG:AG,AI:AI")

Application.EnableEvents = False

Dim xCell As Range

For Each xCell In rgChanged
    If Not Intersect(xCell, rgToCheck) Is Nothing Then
        'xcell is within range
        If xCell.Value <> "" And xCell.Offset(0, 1) = "" Then
            'first entry >> set date
            xCell.Offset(0, 1) = Now
        ElseIf xCell.Value = "" Then
            'entry has been removed >> remove date
            xCell.Offset(0, 1).ClearContents
        End If
    End If
Next

Application.EnableEvents = True

End Sub

Having an extra range rgToCheck makes it clearer what have to be updated in case you change your sheets columns.

If put in a normal module, it might make sense to pass the rgToCheck as well, as it might vary from sheet to sheet.