I'm currently setting up a small inventory tool and since I'm new to vba I got stuck.
So I got a table where you can register all the ingoing and outgoing goods and so far I've included a macro which automatically puts the date into the row if the cells in the ingoing and outgoing columns are changed.
What I want to do now is that if I delete a value in the outgoing/ingoing columns the date will disappear too.
That's my code so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
On Error GoTo Ende
Application.EnableEvents = False
For Each rng In Application.Intersect(Columns("D"), Target).Cells
If rng.Offset(0, -2).Value = "" Then
rng.Offset(0, -2).Value = Date
End If
Next rng
Ende:
Application.EnableEvents = True
End Sub
Anyone got an idea?
Quck and dirty fix - add another for loop that checks if the target cell is empty:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
On Error GoTo Ende
Application.EnableEvents = False
For Each rng In Application.Intersect(Columns("D"), Target).Cells
If rng.Offset(0, -2).Value = "" Then
rng.Offset(0, -2).Value = Date
End If
Next rng
For Each rng In Application.Intersect(Columns("D"), Target).Cells
If rng = "" Then
rng.Offset(0, -2).Value = ""
End If
Next rng
Ende:
Application.EnableEvents = True
End Sub
Related
Having trouble executing both Worksheet_Change events correctly. Image below show my results, when modifying column B, column M does nothing. When modifying column L, column N updates as expected but only on row 2. Every other subsequent change to B or M results in N:2 updating to the current time again.
My desired outcome is that when Col B is updated I record a time stamp in Col M and the same when Col L updates that I get a time stamp in Col N.
Example of Excel Error
My current code is here:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim rng As Range
Dim rng2 As Range
If Not Intersect(Target, Columns("B"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
For Each rng In Intersect(Target, Columns("B"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = vbNullString
End If
Next rng
Application.EnableEvents = True
End If
ElseIf Not Intersect(Target, Columns("L"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
For Each rng2 In Intersect(Target, Columns("L"), Target.Parent.UsedRange)
If CBool(Len(rng2.Value2)) And Not CBool(Len(rng2.Offset(0, 2).Value2)) Then
rng2.Offset(0, 2) = Now
ElseIf Not CBool(Len(rng2.Value2)) And CBool(Len(rng2.Offset(0, 2).Value2)) Then
rng2.Offset(0, 2) = vbNullString
End If
Next rng2
Application.EnableEvents = True
End If
Safe_Exit:
End Sub
Mock-up, untested, change of code to simplify as you're doing the same actions in two spots:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim columnLetter as String
Select Case Target.Column
Case 2 'B
columnLetter = "M"
Case 12 'L
columnLetter = "N"
Case Else
Goto Safe_Exit
End Select
Dim loopRng as Range
For Each loopRng In Range(Cells(Target.Row, Target.Column),Cells(Target.End(xlDown).Row,Target.Column)
If IsEmpty(loopRng) = True And IsEmpty(Cells(loopRng.Row,columnLetter)) = False Then
Cells(loopRng.Row,columnLetter) = Now
ElseIf IsEmpty(loopRng) = False And IsEmpty(Cells(loopRng.Row,columnLetter)) = True Then
Cells(loopRng.Row,columnLetter) = vbNullString
End If
Next loopRng
'Columns(columnLetter).NumberFormat = "yyyy/mm/dd"
Application.EnableEvents = True
Safe_Exit:
Application.EnableEvents = True
End Sub
Note that the IsEmpty() = True is important... when using an If case, you need to specify for each condition, otherwise the implicit detection will fail.
Edit1: Removed Intersect from loop, whereas the range i've listed will need corrected... it at least references a specific range, now.
Edit2: Removing .Offset and working with specific column references in cells().
I tried this version of my original code and it started to work for some reason.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = vbNullString
End If
Next rng
End If
If Not Intersect(Target, Columns("L"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
For Each rng In Intersect(Target, Columns("L"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 2).Value2)) Then
rng.Offset(0, 2) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 2).Value2)) Then
rng.Offset(0, 2) = vbNullString
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
I've got a sheet with Data.
I want to calculate the difference between date now and the date which are in cells C3:C10. And the results are stored in cells D3:D10.
That part I got it so far.
But if someone manipulates the values in the result cells then the VBA should recalculate those cells and correct the results.
Private Sub Worksheet_Change(ByVal Target As Range)
For Zeile = 3 To 10
Sheets("Tabelle2").Cells(Zeile, "D") = WorksheetFunction.YearFrac(Sheets("Tabelle2").Cells(Zeile, "C"), Date)
If Sheets("Tabelle2").Cells(Zeile, "C") = 0 Then
Sheets("Tabelle2").Cells(Zeile, "D") = ""
End If
Next Zeile
End Sub
The first thing to do is check if the change has been made in C3:C10, you can use Intersect for that.
Then you should disable events to stop the code triggering itself, use Application.EnableEvents = False for that.
Next loop through Target in case more than one cell has been changed and perform the required actions/calculations.
Finally re-enable events using Application.EnableEvents = True
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim cell As Range
Dim Zeile As Long
Set rng = Intersect(Target, Range("C3:C10"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng.Cells
Zeile = cell.Row
If Cells(Zeile, "C") <> 0 Then
Cells(Zeile, "D") = Application.YearFrac(Cells(Zeile, "C").Value, Date)
Else
Cells(Zeile, "D") = ""
End If
Next cell
Application.EnableEvents = True
End If
End Sub
If you want the code to be triggered if a value is changed in either C3:C10 or D3:D10 change this,
Set rng = Intersect(Target, Range("C3:C10"))
to this.
Set rng = Intersect(Target, Range("C3:D10"))
You can also change the range address there if you want to further rows by changing 10.
I am having a problem of an infinite loop which is caused by the code below.
It is caused by changes in column E affecting changes in G and vice-versa constantly triggering Worksheet_Change(ByVal Target As Range)
In the below code I could stop this with a line that tests if the last change was made by the user or by VBA. Is there a way to test this condition?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E:E")) Is Nothing Then Macro
If Not Intersect(Target, Range("G:G")) Is Nothing Then Macro2
End Sub
Private Sub Macro()
Dim rng As Range
Dim i As Long
Set rng = Range("E1:E10")
For Each cell In rng
If cell.Value <> "" Then
If IsNumeric(cell.Value) Then
cell.Offset(0, 2).Value = cell.Value + cell.Offset(0, 1)
End If
Else
cell.Offset(0, 2).Value = 1
End If
Next
End Sub
Private Sub Macro2()
Dim rng As Range
Dim i As Long
Set rng = Range("G1:G10")
For Each cell In rng
If cell.Value <> "" Then
If IsNumeric(cell.Value) Then
cell.Offset(0, -2).Value = cell.Value - cell.Offset(0, -1)
End If
Else
cell.Offset(0, -2).Value = 1
End If
Next
End Sub
temporarily disable events triggering:
Private Sub Macro()
Dim rng As Range
Dim i As Long
Set rng = Range("E1:E10")
On Error GoTo HandleExit ' assure proper handling of any error
Application.EnableEvents = False 'disable events triggering
For Each cell In rng
If cell.Value <> "" Then
If IsNumeric(cell.Value) Then
cell.Offset(0, 2).Value = cell.Value + cell.Offset(0, 1)
End If
Else
cell.Offset(0, 2).Value = 1
End If
Next
HandleExit:
Application.EnableEvents = True 'enable back events triggering
End Sub
the same with Macro2
EDIT to add a possible refactoring of the code
BTW, your Sub Macro() could be rewritten with no loops and without relying on IsNumeric() function (which is not 100% reliable (e.g. IsNumeric("12.5.3") would return True)
Private Sub Macro()
On Error GoTo HandleExit ' assure proper handling of any error
Application.EnableEvents = False 'disable events triggering
With Range("E1:E10") 'reference your range
If WorksheetFunction.Count(.Cells) > 0 Then ' if any "truly" numeric values in referenced range
With .SpecialCells(xlCellTypeConstants, xlNumbers).Offset(, 2) ' reference referenced range cells with constant numeric content only
.FormulaR1C1 = "=sum(RC[-1]:RC[-2])" ' write needed formula
.Value = .Value ' get rid of the formula
End With
End If
If WorksheetFunction.CountBlank(.Cells) Then .SpecialCells(xlCellTypeBlanks).Offset(, 2).Value = 1 ' if any blank cell in referenced range then fill it with 1"
End With
HandleExit:
Application.EnableEvents = True 'enable back events triggering
End Sub
i have the following code which would auto-fill the date in column B once i add value's in column A.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date & " " & Time = "hh:mm:ss AM/PM"
End If
Next r
Application.EnableEvents = True
End Sub
what im looking for is to also add the current time to column C.
ok so i found what im looking for but it requires little modification where the date and time are being set.
below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("D:D")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Value > 0 Then
r.Offset(0, -3).Value = Date
r.Offset(0, -3).NumberFormat = "dd-mm-yyyy"
r.Offset(0, -2).Value = Time
r.Offset(0, -2).NumberFormat = "hh:mm:ss AM/PM"
Else
r.Offset(0, -3).Value = ""
r.Offset(0, -2).Value = ""
End If
Next r
Application.EnableEvents = True
End Sub
to auto-fill column E with date, instead of column A
and auto-fill column F with time, instead of column B
and if possible im trying to have the same process but another cell on the same sheet.
While you might look at using SpecialCells to do this in one hit rather than a loop, a simple mod to your code would be:
one-shot per range area method
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error Resume Next
For Each r In Inte.Areas
r.Offset(0, 1).Cells.SpecialCells(xlCellTypeBlanks) = Date
r.Offset(0, 2).Cells.SpecialCells(xlCellTypeBlanks) = Time
Next r
Application.EnableEvents = True
End Sub
initial answer
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = vbNullString Then r.Offset(0, 1).Value = Date
If r.Offset(0, 2).Value = vbNullString Then r.Offset(0, 2).Value = Time
Next r
Application.EnableEvents = True
End Sub
if you want to:
put current Date in Target adjacent column blank cells
put current Time in Target adjacent column blank cells adjacent cells
then go like follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A"
Application.EnableEvents = False
If WorksheetFunction.CountBlank(Target.Offset(, 1)) = 0 Then Exit Sub '<--| exit if no blank cells in target adjacent column
With Target.Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference blank cells in target adjacent column
.Value = Date '<--| set referenced cells value to the current date
.Offset(, 1).Value = Time '<--| set referenced cells adjacent ones value to the current time
End With
Application.EnableEvents = True
End Sub
While if you want to:
put current Date in Target adjacent column blank cells
put current Time in Target two columns offset blank cells
then go like follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A"
Application.EnableEvents = False
On Error Resume Next
Target.Offset(, 1).SpecialCells(xlCellTypeBlanks).Value = Date '<--| set target adjacent column blank cells to the current date
Target.Offset(, 2).SpecialCells(xlCellTypeBlanks).Value = Time '<--| set target two columns offset blank cells to the current time
Application.EnableEvents = True
End Sub
where the On Error Resume Next is there to avoid two distinct If WorksheetFunction.CountBlank(someRange) Then someRange.SpecialCells(xlCellTypeBlanks).Value = someValue statements
Normally you would avoid On Error Resume Next statement and ensure you're handling any possible errors.
But in this case, being it confined to the last two statements of a sub, I think it's a good trade off in favour of code readability without actually loosing its control
The code below works fine when I manually update column I. What I need is to know if there is a way to still have this code work when I have column I updated by a formula.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("I3:I30"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, -1).ClearContents
Else
With .Offset(0, -1)
.NumberFormat = "m/d/yy h:mm"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
Worksheet_Change does not fire in responce to a formula update.
See Excel help for Worksheet_Change
Occurs when cells on the worksheet are changed by the user or by an external link.
You could maybe achieve what you want with the Worksheet_Calculate event.
Assuming you want to put a time stamp next to the cells when those vall values change, try this (in addition to your Change event).
Note the use of the Static variable to track previous values, since Calculate event does nopt provide a Target parameter like Change does. This method may not be robust enough since Static's get reset if you break vba execution (eg on an unhandled error). If you want it more robust, consider saving previous values on another (hidden) sheet.
Private Sub Worksheet_Calculate()
Dim rng As Range, cl As Range
Static OldData As Variant
Application.EnableEvents = False
Set rng = Me.Range("I3:I30")
If IsEmpty(OldData) Then
OldData = rng.Value
End If
For Each cl In rng.Cells
If Len(cl) = 0 Then
cl.Offset(0, -1).ClearContents
Else
If cl.Value <> OldData(cl.Row - rng.Row + 1, 1) Then
With cl.Offset(0, -1)
.NumberFormat = "m/d/yy h:mm:ss"
.Value = Now
End With
End If
End If
Next
OldData = rng.Value
Application.EnableEvents = True
End Sub
Update
Tested routine on sample sheet, all works as expected
Sample file contains the same code repeated on 25 sheets, and range to time stamp is 10000 rows long.
To avoid repeating the code, use the Workbook_ events. To minimise run time use variant arrays for the loop.
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim rng As Range
Dim NewData As Variant
Dim i As Long
Static OldData As Variant
Application.EnableEvents = False
Set rng = Sh.Range("B2:C10000") ' <-- notice range includes date column
NewData = rng
If IsEmpty(OldData) Then
OldData = rng.Value
End If
For i = LBound(NewData, 1) To UBound(NewData, 1)
If Len(NewData(i, 1)) = 0 And Len(NewData(i, 2)) > 0 Then
rng.Cells(i, 2).ClearContents
Else
If NewData(i, 1) <> OldData(i, 1) Then
With rng.Cells(i, 2)
.NumberFormat = "m/d/yy -- h:mm:ss"
.Value = Now
End With
End If
End If
Next
OldData = rng.Value
Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Activate date population on cell change
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Sh.Range("B2:B10000"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 1).ClearContents
Else
'Populate date and time in column c
With .Offset(0, 1)
.NumberFormat = "mm/dd/yyyy -- hh:mm:ss"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub