VBA Worksheet_Change Only Working For One Cell - excel

I'd like to preface by saying I am a novice to VBA, so hopefully this is an easy fix.
I am trying to get the following VBA code to work for multiple cells with formulas. The effect is that there is a ghost value in the cell a user can overwrite then see again if they delete their value. I can get one cell to work how I want it to, but the second (and third and fourth etc.) do not work. How can I repeat this same line of code so that the effect repeats itself in multiple cells with different formulas?
Working:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F7" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub
My attempt (Top working, bottom not):
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F7" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub
Private Sub Worksheet_Change1(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F8" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),9),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub

Try this...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, j&, v, t
v = Target.Value2
If Not IsArray(v) Then t = v: ReDim v(1 To 1, 1 To 1): v(1, 1) = t
Application.EnableEvents = False
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
If Len(v(i, j)) = 0 Then
With Target(i, j)
Select Case .Address(0, 0)
Case "A1": .Formula = "=""Excel"""
Case "A2": .Formula = "=""Hero"""
End Select
End With
End If
Next
Next
Application.EnableEvents = True
End Sub
Use your formulas and ranges instead of mine, of course.
Update
The above works well, but this is faster/better...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, v
DoEvents
ReDim v(1 To 3, 1 To 2)
v(1, 1) = "A1": v(1, 2) = "=""This"""
v(2, 1) = "A2": v(2, 2) = "=""Works"""
v(3, 1) = "A2": v(3, 2) = "=""Great!"""
Application.EnableEvents = False
For i = 1 To UBound(v)
With Range(v(i, 1))
If Not Intersect(Target, .Cells) Is Nothing Then
If Len(.Value2) = 0 Then
.Formula = v(i, 2)
End If
End If
End With
Next
Application.EnableEvents = True
End Sub
Both of the above methods work for single-cell deletes AND also for clearing and deleting large ranges, including whole columns and whole rows and the second method is particularly quick in all these scenarios.

You can do something like this:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'only handle single cells
If Target.Cells.CountLarge > 1 Then Exit Sub
If IsError(Target.Value) Then Exit Sub '<< edit: added
'only handle empty cells
If Len(Target.Value) > 0 Or Len(Target.Formula) > 0 Then Exit Sub
On Error Goto haveError
Application.EnableEvents = False
Select Case Target.Address(False, False)
Case "F7": Target.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Case "F8": Target.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),9),0)"
End Select
haveError:
'ensure events are re-enabled
Application.EnableEvents = True
End Sub

Related

Delete entire based on another cell value

I need help with Excel VBA code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
If the third column we enter -1 it will clear the row. If we enter 1000 it will be copied to another sheet and deleted from the current sheet.
The above code is working fine. Instead of clearing row data, I want to delete that row.
So added
Line 4 With Target.EntireRow.ClearContents to With Target.EntireRow.Delete
But it shows an error.
It would help to know what error you get. Assuming the error is caused because the Week Schedule sheet does not exist, you can add a check for that. After that, your code works fine:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
SheetExistsOrCreate ("Week Schedule")
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
Function SheetExistsOrCreate(name As Variant)
For i = 1 To Worksheets.Count
If Worksheets(i).name = "MySheet" Then
exists = True
End If
Next i
If Not exists Then
Worksheets.Add.name = name
End If
End Function
Please, try the next adapted code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
Application.EnableEvents = False
If LCase(Target.Value) = -1 Then
Target.EntireRow.Delete
ElseIf Target.Value = 1000 Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
Application.EnableEvents = True
End If
End Sub
The above code assumes that the Target value means a number, not a string looking as a number. If a string, you can place them between double quotes, as in your initial code.
Of course, a sheet named "Week Schedule" must exist in the active workbook and must not be protected.

Combining Worksheet_Change events in vba code

I require some help in combining two Worksheet_Change events. Event 1 will reformat the cell to the correct postcode format & event 2 will apply the proper function. How can i combine event 1 & 2 in order for both to work at the same time?
Any help would be greatly appreciated :)
Event 1
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("K17")) Is Nothing Then Exit Sub
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[A-Z]{1,2}[0-9]{1,2}\s[0-9][A-Z]{2}"
If Not .test(Cells(17, 11)) Then
Cells(17, 11) = UCase(Left(Cells(17, 11), Len(Cells(17, 11)) - 3) & " " & Right(Cells(17, 11), 3))
End If
End With
End Sub
Event 2
Private Sub Worksheet_Change2(ByVal Target As Range)
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("F7;K7")) Is Nothing Then
Application.EnableEvents = False
Target = StrConv(Target, vbProperCase)
Application.EnableEvents = True
End If
End Sub
Why not just split into two independent macros that each run during the Change event? The below might work. I'd be careful about doing .cells.count as that can be a lot if you delete an entire column or a wide range of data.
Private Sub Worksheet_Change(ByVal Target As Range)
Call macroFirst(Target)
Call macroSecond(Target)
End Sub
Private Sub macroFirst(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("K17")) Is Nothing Then Exit Sub
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[A-Z]{1,2}[0-9]{1,2}\s[0-9][A-Z]{2}"
If Not .test(Cells(17, 11)) Then
Cells(17, 11) = UCase(Left(Cells(17, 11), Len(Cells(17, 11)) - 3) & " " & Right(Cells(17, 11), 3))
End If
End With
End Sub
Private Sub macroSecond(ByVal Target As Range)
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("F7;K7")) Is Nothing Then
Application.EnableEvents = False
Target = StrConv(Target, vbProperCase)
Application.EnableEvents = True
End If
End Sub

Excel 2 Worksheets Events with Different Targets

I have an excel worksheet that I want to assign to it more than one Worksheet Event.
To be more specific, I want whenever a cell in column B is changed then one cell to the left (column A) gets the row number.
Also I want whenever a cell in column J is changed then one cell to the right (column K) gets today's date.
It worked for me for both of them individually but I think I may be doing something wrong using them together.
Any help will be much appreciated!
Private Sub AG1(ByVal a_Target As Range)
If Not Intersect(a_Target, Me.Range("B2:B3000")) Is Nothing Then
Application.EnableEvents = False
Cells(a_Target.Row, a_Target.Column - 1) = a_Target.Row
Application.EnableEvents = True
End If
End Sub
Private Sub AG2(ByVal b_Target As Range)
If Not Intersect(b_Target, Me.Range("J2:J3000")) Is Nothing Then
Application.EnableEvents = False
Cells(b_Target.Row, b_Target.Column + 1) = Date
Application.EnableEvents = True
End If
End Sub
edit - works now (I also added that column can be referred as letter):
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = True
If Split(Cells(1, Target.Column).Address(True, False), "$")(0) = "B" Then
Application.EnableEvents = False
Cells(Target.Row, Target.Column - 1) = Target.Row
Application.EnableEvents = True
ElseIf Split(Cells(1, Target.Column).Address(True, False), "$")(0) = "J" Then
Application.EnableEvents = False
Cells(Target.Row, Target.Column + 1) = Date
Application.EnableEvents = True
End If
End Sub
Copy the code in the Worksheet_Change event and that should fix your issue. This will trigger every time you enter a value for any cell and will only meet the condition if they intersect the range in the if statement.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B2:B3000")) Is Nothing Then
Application.EnableEvents = False
Cells(Target.Row, Target.Column - 1) = Target.Row
Application.EnableEvents = True
End If
If Not Intersect(Target, Me.Range("J2:J3000")) Is Nothing Then
Application.EnableEvents = False
Cells(Target.Row, Target.Column + 1) = Date
Application.EnableEvents = True
End If
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

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

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

Resources