How to run VBA code when cell contents are changed via formula - excel

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

Related

How can I build For-Next-Loop in Change Event?

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.

How to solve the VBA error invalid inside procedure

I am currently trying to run this VBA code and keep getting the repeated error 'Invalid inside procedure'. Could anyone suggest what part of the code is wrong?
I have attempted to fault find however can not seem to find the root of the problem.
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("C:C"), .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
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("G:G"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 12).ClearContents
Else
With .Offset(0, 12)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
Option Explicit
Const sCell As String = "G2" ' Source First Cell
Const dCol As Variant = "J" ' Destination Column Id (String or Index)
Dim irg As Range ' Intersect Range
Dim cOffset As Long ' Column Offset
With Range(sCell)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
If irg Is Nothing Then Exit Sub
cOffset = Columns(dCol).Column - .Column
End With
Dim arg As Range ' Current Area of Intersect Range
Dim cel As Range ' Current Cell in Current Area of Intersect Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If Not IsError(cel.Value) Then
cel.Offset(, cOffset).Value = cel.Value
End If
Next cel
Next arg
End Sub ```
Try to declare Option Explicit before any procedure -- not within it.

Is there a function that deletes a cells value if I delete the value of another cell in the same row?

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

VBA How to trigger Macro when columns are updated by the user and not VBA?

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

Clear the contents of columns B to F if cell A is empty

I have a worksheet with values depending on Cell A. If a row in column A contains a value then cells from Columns B through H will be changed accordingly.
If Cell of Column A is empty I want to reset the cells from columns D through F.
I wrote down the following VBA Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Integer
For n = 5 To 75
Application.EnableEvents = False
If VarType(Cells(n, 1)) = vbEmpty Then
Cells(n, 4).ClearContents
Cells(n, 5).ClearContents
Cells(n, 6).ClearContents
Application.EnableEvents = True
End If
Next n
End Sub
The "FOR" Loop is annoying, and making the Excel to pause for 1 second or more after any entry to any Cell, can anyone help me correct the above code to do what I need to do without the "FOR" loop.
You are using a Worksheet_Change event and you iterating through 70 rows each time something changes.. this is a bad approach for this kind of problem and that's why there is a delay.
Instead, try
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Long
If Target.Column = 1 Then
If IsEmpty(Cells(Target.Row, 1)) Then
Range("B" & Target.Row & ":F" & Target.Row).ClearContents
End If
End If
End Sub
this will only clear the cells if you remove a value from column A => when cell in column A is empty
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Mid(Target.Address(1, 1), 1, 2) = "$A" Then
If Target.Cells(1, 1).Value = "" Then
For i = 4 To 6
Target.Cells(1, i).Value = ""
Next i
End If
End If
End Sub
Give this a try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("A5:A75")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("D" & rw & ":F" & rw).ClearContents
End If
Next r
Application.EnableEvents = True
End Sub
It should have minimal impact on timing.
Use a range object.
The following line of code will print the address of the Range we'll use to clear the contents. The first cells call gets the upper left corner of the range, the second cells call gets the lower right corner of the range.
Private Sub test()
Debug.Print Range(Cells(5, 4), Cells(75, 6)).Address
End Sub
We apply this to your code like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
Application.EnableEvents = True
End If
End Sub
One final sidenote: You should use an error handler to make sure events are always enabled when the sub exits, even if an error occurs.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
End If
ExitSub:
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox "Oh Noes!", vbCritical
Resume ExitSub
End Sub
You should disable events and cater for multiple cells when using the Change event.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Columns("A"), Target)
If rng1 Is Nothing Then Exit Sub
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each rng2 In rng1.Cells
If IsEmpty(rng2.Value) Then rng2.Offset(0, 1).Resize(1, 5).ClearContents
Next
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
For those that need to have data entered in one cell cleared (in a column) when there's a change in another column use this, which is a modification of Gary's Student.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("D:D")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("L:L").ClearContents
End If
Next r
Application.EnableEvents = True
End Sub

Resources