How do I record Date When Cell Changes? - excel

I have below code when the date is changing while any of cells is updated. But the challenge that I have is with the cell where the date is display. I need the data to be updated always only in column E. How to change - xOffsetColumn = 1 to get there?
Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub


This now works for any intersect range.
I tested the below and it works for me.
Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim dateCol%, xOffsetColumn%
Dim Rng As Range, WorkRng As Range
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets(Target.Parent.Name)
'Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
Set WorkRng = Intersect(Application.ActiveSheet.Range("E:AV"), Target)
'dateCol = 5
dateCol = 4
xOffsetColumn = 3
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.value) Then
' Rng.Offset(0, xOffsetColumn).value = Now
' Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
WS.Cells(Rng.row, dateCol) = Now()
WS.Cells(Rng.row, dateCol).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

Related

Fill in date in specific column & Row based on cell value

I have received a request to fill in date based on specific status chosen (cell value) in a column representing that status.
For example if I choose a Status "Event_1" in column A from a drop down list, macro should find a column with the same name (Event_1) and fill in date in that column for the Row where the status was changed.
I only got as far as filling adjacent cell with a date when said cell is changed. I know I should probably adjust offset to a column number representing my status, however I'm not sure how to achieve this.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim ColNum As Integer
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("A:A"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 1).ClearContents
Else
With .Offset(0, 1)
.NumberFormat = "dd mmm yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub

What about this?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ColNum As Integer
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("A:A"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
'.Offset(0, 1).ClearContents
'Why???
Else
ColNum = Application.WorksheetFunction.Match(Target.Value, Range("1:1"), 0)
With .Offset(0, ColNum - 1)
.NumberFormat = "dd mmm yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
The only part I don't get is this one:
If IsEmpty(.Value) Then
.Offset(0, 1).ClearContents
Why? You should specify what you want to do when there is no option selected.

A Worksheet Change: One Timestamp Per Row
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
Const FirstColCellAddress As String = "B1"
Const FirstRowCellAddress As String = "A2"
Const TimeFormat As String = "dd/mm/yyyy hh:mm:ss"
Dim scrg As Range
With Range(FirstRowCellAddress)
Set scrg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
Dim irg As Range: Set irg = Intersect(scrg, Target)
If irg Is Nothing Then Exit Sub
Dim srrg As Range
Dim sCell As Range
With Range(FirstColCellAddress)
Set sCell = .Resize(, .Worksheet.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
Set srrg = .Resize(, sCell.Column - .Column + 1)
End With
Dim sIndex As Variant
Dim sString As String
Dim drrg As Range
Dim dCell As Range
Dim rgClear As Range
Dim rgTime As Range
For Each sCell In irg.Cells
Set drrg = srrg.Rows(sCell.Row - srrg.Row + 1)
If rgClear Is Nothing Then
Set rgClear = drrg
Else
Set rgClear = Union(rgClear, drrg)
End If
sString = CStr(sCell.Value)
sIndex = Application.Match(sString, srrg, 0)
If IsNumeric(sIndex) Then
Set dCell = drrg.Cells(sIndex)
If rgTime Is Nothing Then
Set rgTime = dCell
Else
Set rgTime = Union(rgTime, dCell)
End If
End If
Next sCell
Application.EnableEvents = False
If Not rgClear Is Nothing Then rgClear.Clear
If Not rgTime Is Nothing Then
Dim TimeStamp As Date: TimeStamp = Now
With rgTime
.NumberFormat = TimeFormat
.Value = TimeStamp
End With
End If
SafeExit:
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub

How do i populate 2 columns with static dates

Am using the following code that works for populating static dates in column C when data is filled in column B.
I would like to also have column E populated with static dates if data is filled in column D. Please advise tq
Private Sub Worksheet_Change(ByVal Target As Range)
'Update 20140722
Dim WorkRng As Range
Dim Rng As Range Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

A Worksheet Change: Time Stamp and Clear
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const fRow As Long = 1 ' possibly 2 or more to exclude headers
Const cOffset As Long = 1
' Reference the intersecting range.
Dim irg As Range ' Intersect
With Columns("B")
With .Resize(.Rows.Count - fRow + 1).Offset(fRow - 1)
'Debug.Print Union(.Cells, .EntireRow.Columns("D")).Address
Set irg = Intersect(Union(.Cells, .EntireRow.Columns("D")), Target)
End With
End With
If irg Is Nothing Then Exit Sub
Dim trg As Range ' Time
Dim crg As Range ' Clear
Dim iCell As Range
' Combine cells into the Time and Clear ranges.
For Each iCell In irg.Cells
If Not VBA.IsEmpty(iCell.Value) Then
If trg Is Nothing Then Set trg = iCell _
Else Set trg = Union(trg, iCell)
Else
If crg Is Nothing Then Set crg = iCell _
Else Set crg = Union(crg, iCell)
End If
Next iCell
Application.EnableEvents = False
' Write.
If Not trg Is Nothing Then
With trg.Offset(, cOffset)
.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
.Value = Now
End With
End If
If Not crg Is Nothing Then
crg.Offset(, cOffset).ClearContents
End If
Application.EnableEvents = True
End Sub

Excel Record Date And Time Automatically When Cell Changes VBA

I am using the following VBA code to automatically timestamp dates when I edit or change cells. It works perfectly however, whenever i delete a row it will cause the cell directly under it to refresh its timestamp, this is very annoying and has led me to hide unwanted rows instead of deleting them, appreciate if you can help me fix this through changes in the VBA.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

You can ignore changes which involve a whole row or rows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range, c As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
'whole row(s) changed - do not process
If Target.Columns.Count = Me.Columns.Count Then Exit Sub
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
Set c = Rng.Offset(0, xOffsetColumn) '****
If Not VBA.IsEmpty(Rng.Value) Then
c.Value = Now
c.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
c.ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

Generate datetime when entry made in cell

I have code which should display the date in column A whenever something is entered in column B.
I enabled macros in security settings.
The VBA code is in ThisWorkbook under the project because I want the same thing to happen on every sheet.
Private Sub Workbook_SheetChange(ByVal Sh As Object, _
ByVal Source As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("B:B"), Target)
xOffsetColumn = -1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

A couple of changes:
1) First, you need(ed) to change to the workbook level event: the Workbook.SheetChange event.
2) Then change Application.ActiveSheet to Sh.
3) Make sure that the parameter is named Target if you're using Target within the code body.
4) Add some error handling to make sure events always get re-enabled:
Private Sub Workbook_SheetChange(ByVal Sh As Object, _
ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Sh.Range("B:B"), Target)
xOffsetColumn = -1
If Not WorkRng Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
End If
SafeExit:
Application.EnableEvents = True
End Sub

Something for you to consider (if you desire so) is to catch Now before you Loop to prevent different values. In such case you might not even want a loop at all. Consider to replace:
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
With:
'Non empty cells with constants
If Application.CountA(WorkRng) > 0 Then
Set Rng = WorkRng.SpecialCells(xlCellTypeConstants).Offset(0, -1)
Rng.Value = Now
Rng.NumberFormat = "dd-mm-yyyy, hh:mm:ss"
End If
And:
'Empty Cells
If Application.CountBlank(WorkRng) > 0 Then
WorkRng.SpecialCells(xlCellTypeBlanks).Offset(0, -1).ClearContents
End If
You could implement this within the answer given by #BigBen if you will.

How to stop code overwriting cells with values in them

I'm trying to tweak the following code which enters today's date in column B when you change column A. I'd only like this code to run when column B is empty as I'm experiencing an issue where worksheet_change is too broad and past dates entered are getting overwritten when new changes are made inadvertently.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("A:A"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Date
Rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yyyy"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

You could check if the value is already a date
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("A:A"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
With Rng.Offset(0, xOffsetColumn)
If Not VBA.Information.IsDate(.Value) Then
.Value = Date
.NumberFormat = "mm-dd-yyyy"
End If
End With
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

Resources