Detect when individual cells were changed, cells not in a range...

spacely

Board Regular
Joined
Oct 26, 2007
Messages
241
I poked around on the forums, and solved it:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim KeyCells As Range
Dim isect As Range
Dim cell As Range
Dim rDependents As Range

If [captureCellHistory].Value = 1 Then
Set KeyCells = Range("S:ZZ") ' should be big enough to capture all hardware added, I hope...specify non-continuous ranges like: Range("AK98, AL99, AN101:AN104")
Set isect = Intersect(KeyCells, Target)

If Not isect Is Nothing Then ' detects things typed into cells, and if a VBA script changes the cell value. Doesn't detect changes due to recalculations due to cell formulas!
For Each cell In isect
lastRow = Worksheets("cell histories").Cells(Rows.Count, 1).End(xlUp).Row ' add onto bottom of cell history list
Worksheets("cell histories").Cells(lastRow + 1, 1).Value = Now ' date/time of this edit
Worksheets("cell histories").Cells(lastRow + 1, 2).Value = Application.UserName ' username of person who made edit
Worksheets("cell histories").Cells(lastRow + 1, 3).Value = ActiveSheet.name ' sheet name of this edit
Worksheets("cell histories").Cells(lastRow + 1, 4).Value = cell.Row ' row number of this edit
Worksheets("cell histories").Cells(lastRow + 1, 5).Value = cell.Column ' column number of this edit
Worksheets("cell histories").Cells(lastRow + 1, 6).Value = cell.Value ' cell value of this edit
Next cell
End If

On Error Resume Next
Set rDependents = Target.Dependents
If Err.Number > 0 Then
Exit Sub
End If
Set isect = Intersect(rDependents, KeyCells)
If Not isect Is Nothing Then ' detects cell changes due to formula calculations
For Each cell In isect
lastRow = Worksheets("cell histories").Cells(Rows.Count, 1).End(xlUp).Row ' add onto bottom of cell history list
Worksheets("cell histories").Cells(lastRow + 1, 1).Value = Now ' date/time of this edit
Worksheets("cell histories").Cells(lastRow + 1, 2).Value = Application.UserName ' username of person who made edit
Worksheets("cell histories").Cells(lastRow + 1, 3).Value = ActiveSheet.name ' sheet name of this edit
Worksheets("cell histories").Cells(lastRow + 1, 4).Value = cell.Row ' row number of this edit
Worksheets("cell histories").Cells(lastRow + 1, 5).Value = cell.Column ' column number of this edit
Worksheets("cell histories").Cells(lastRow + 1, 6).Value = cell.Value ' cell value of this edit
Next cell
End If
End If

End Sub
 

Forum statistics

Threads
1,085,429
Messages
5,383,622
Members
401,842
Latest member
BathAntelope

Some videos you may like

This Week's Hot Topics

Top