2

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
Improve this question

2 Answers 2

Reset to default
2

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
Improve this answer
Sign up to request clarification or add additional context in comments.

Comments

1

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.

Improve this answer

Comments

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.