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
Related
I am trying to link 2 cells that have data validation lists in them so that when 1 of the cells (ex. cell A2) is filled with the SKU in from a selection in the dropdown list, cell B2 will be filled with the SKU description and vice versa.
See the pictures below with that I have so far. I have named the columns:
Column A = a_val
Column B = b_val
SKU column with values = vrac
SKU description column with values = vrac_description
Table with SKUs and SKU descriptions = description
See the attached pictures for what I currently have.
1 sheet is the empty fields, I have data validation lists on columns A and B since I want to be able to have the option to select either from column A or column B but would like either one to auto-populate when I've selected an item from the list in the opposite cell
Thank you!
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("a_val")) Is Nothing Then
With Application.WorksheetFunction
UI False
Range("b_val").Value = .Index(Range("vrac_description").Value, .Match(Range("a_val").Value, Range("description").Value, 0))
UI True
End With
ElseIf Not Intersect(Target, [b_val]) Is Nothing Then
With Application.WorksheetFunction
UI False
[a_val].Value = .Index([vrac], .Match([b_val], [vrac_description], 0))
UI True
End With
End If
End Sub
Public Sub UI(t As Boolean)
Application.EnableEvents = t
Application.ScreenUpdating = t
End Sub
Current Code
Main Sheet
Data Validation Lookup
[EDIT} New code attempt:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, a_val) Is Nothing Then
With Application.WorksheetFunction
UI False
'b_val = .VLookup(Target, Description, 1, 0)
Range(Target.Column + 1).Value = .Index(vrac_description, .Match(Target.Value, vrac, 0))
UI True
End With
ElseIf Not Intersect(Target, b_val) Is Nothing Then
With Application.WorksheetFunction
UI False
'Range(Target.Column - 1).Value = .VLookup(Target.Value, Description, 1, 0)
Range(Target.Column - 1).Value = .Index(vrac, .Match(Target.Value, vrac_description, 0))
UI True
End With
End If
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Msgbox "Target=" & Target.Address
On Error GoTo errorexit
Dim r, i As Long, cell As Range
i = Target.Column
If i > 2 Or Target.Value = "" Then Exit Sub
Set cell = Target.Offset(, 3 - i * 2)
With Sheets("Data_Validation").ListObjects("description").DataBodyRange
r = Application.Match(Target.Value, .Columns(i), 0)
If Not IsError(r) Then
Application.EnableEvents = False
cell = .Cells(r, 3 - i).Value
Else
MsgBox Target.Value & " not found in column " & i
End If
End With
errorexit:
Application.EnableEvents = True
End Sub
Your code corrected
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo exiterror
Dim a_val As Range, b_val As Range
Dim vrac As Range, vrac_description As Range
' define ranges
With ThisWorkbook
Set a_val = .Names("a_val").RefersToRange
Set b_val = .Names("b_val").RefersToRange
Set vrac = .Names("vrac").RefersToRange
Set vrac_description = .Names("vrac_description").RefersToRange
End With
If Not Intersect(Target, a_val) Is Nothing Then
With Application.WorksheetFunction
UI False
Target.Offset(, 1).Value = .Index(vrac_description, .Match(Target.Value, vrac, 0))
UI True
End With
ElseIf Not Intersect(Target, b_val) Is Nothing Then
With Application.WorksheetFunction
UI False
Target.Offset(, -1).Value = .Index(vrac, .Match(Target.Value, vrac_description, 0))
UI True
End With
End If
exiterror:
Application.EnableEvents = True
End Sub
I need to copy the contents of a cell in a particular column to another corresponding column on change so the old value is moved. Only wants to work for a particular column.
Private sub Worksheet_Change(ByVal Target As Range)
if Target.Range("L:L") then
'set I cell value = to original L cell value
ActiveCell.Offset(0,-3).Value = ActiveCell.Value
End If
End Sub
This code should do what you want. Please take note of the comments which explain some limitations I have imposed on the action of this procedure. The rule to follow is to not give it more power than it needs to do the job you want it to do.
Private Sub Worksheet_Change(ByVal Target As Range)
' 027
Dim Rng As Range
' don't react if the changed cell is in row 1 or
' if it is more than 1 row below the end of column L
Set Rng = Range(Cells(2, "L"), Cells(Rows.Count, "L").End(xlUp).Offset(1))
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Target
' skip if more than 1 cell was changed
' meaning, exclude paste actions
If .Cells.CountLarge = 1 Then
.Offset(0, -3).Value = .Value
End If
End With
End If
End Sub
This will save the previous value in column I:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v As Variant
If Target.Count > 1 Then Exit Sub
If Intersect(Range("L:L"), Target) Is Nothing Then Exit Sub
With Application
v = Target.Value
.EnableEvents = False
.Undo
Target.Offset(0, -3).Value = Target.Value
Target.Value = v
.EnableEvents = True
End With
End Sub
EDIT#1:
To update L without triggering the event, use something like:
Sub ScriptThatUpdatesColumn_L()
Application.EnableEvents = False
Range("L5").Value = "just me"
Application.EnableEvents = True
End Sub
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
I am using a simple code to enter date and time automatically in 2 separate cells in the excel sheet, however, they change automatically if I enter a new value in the cell or just press "Delete" Key. Below is the code I am using:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 5 Then Exit Sub
Application.EnableEvents = False
Target.Offset(0, -2).Value = Date
Application.EnableEvents = True
If Target.Column <> 5 Then Exit Sub
Application.EnableEvents = False
Target.Offset(0, -1).Value = Time
Application.EnableEvents = True
End Sub
I need the date and time to remain static until I delete them from their respective cells. How can I achieve this?
This will preserve the date/time once they have been entered:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 5 Then Exit Sub
Application.EnableEvents = False
If Target.Offset(0, -2).Value = "" And Target.Offset(0, -2).Value = "" Then
Target.Offset(0, -2).Value = Date
Target.Offset(0, -1).Value = Time
End If
Application.EnableEvents = True
End Sub
EDIT#1:
This version will allow you to both set and clear multiple cells in column E:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, i1 As Long, i2 As Long
If Target.Column <> 5 Then Exit Sub
With ActiveSheet.UsedRange
i2 = .Rows.Count + .Row - 1
i1 = .Row
End With
Application.EnableEvents = False
For Each r In Intersect(Target, Range("E" & i1 & ":E" & i2))
If r.Offset(0, -2).Value = "" And r.Offset(0, -1).Value = "" And r.Value <> "" Then
r.Offset(0, -2).Value = Date
r.Offset(0, -1).Value = Time
End If
Next r
Application.EnableEvents = True
End Sub
Clearing a cell that is already empty will not cause a time/date recording.
Stepping through your code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 5 Then Exit Sub
"If the target's column is not 5 then exit the subroutine" This is cool.
Application.EnableEvents = False
Flipping this to false insures that this code won't run again until this value is set to true. Worksheet_Change needs enableevents to be on. So now if the cell that changed was in Column E then Worksheet_Change will be kept from executing again. This makes sense to keep infinite loops from happening as cells are changed via this code.
Target.Offset(0, -2).Value = Date
Set the cell that is two columns back from the target cell to the current date.
Application.EnableEvents = True
Set enableEvents back on. This is good since you probably don't want to leave this off.
If Target.Column <> 5 Then Exit Sub
Why are we checking this again? Target.Column hasn't changed since last time, and if it was already <>5 then we wouldn't be here to test it. This line is superfluous.
Application.EnableEvents = False
OK.. Well we just turned this on, but now we are turning this off again. Just leave it off.
Target.Offset(0, -1).Value = Time
Set the value 1 column to the left of the target cell to the current time. Coolios.
Application.EnableEvents = True
Turn enableEvents back on. This makes sense here.
End Sub
Rewriting this to remove the redundant toggles and superflous target.Column check:
Private Sub Worksheet_Change(ByVal Target As Range)
'make sure this is column 5 that was changed. Like if anything changed in
' column 5, then run the rest of this.
If Target.Column <> 5 Then Exit Sub
'Make sure we don't infinite loop if we accidently trigger a change to
' column 5 in this code.
Application.EnableEvents = False
' Set two cells to the left to the current date
' and one cell to the left to the current time
Target.Offset(0, -2).Value = Date
Target.Offset(0, -1).Value = Time
'turn events back on.
Application.EnableEvents = True
End Sub
So.. Everytime you make a change in Column 5, the date and time change. IF you want it so that it only changes a row's date and time once. Then check to see if date and time are already set for the row:
Private Sub Worksheet_Change(ByVal Target As Range)
'make sure this is column 5 that was changed. Like if anything changed in
' column 5, then run the rest of this.
If Target.Column <> 5 Then Exit Sub
'Check to see if the date and time are already set for this row:
' If they are, then exit subroutine.
If target.offset(0,-2).value <> "" OR target.offset(0,-1).value <> "" Then Exit Sub
'Make sure we don't infinite loop if we accidently trigger a change to
' column 5 in this code.
Application.EnableEvents = False
' Set two cells to the left to the current date
' and one cell to the left to the current time
Target.Offset(0, -2).Value = Date
Target.Offset(0, -1).Value = Time
'turn events back on.
Application.EnableEvents = True
End Sub
I need to add cell A to cell B of the same row and then reset cell A to zero. I did some searching and found this code that works perfectly, but I need to have it work for an entire column not just one row.
So, all of column A should add to column B, but only on the same row. Here is the code I found:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = Range("a1").Address Then
Range("b1") = Range("b1") + Range("a1")
Range("a1").ClearContents
End If
Application.EnableEvents = True
End Sub
And:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range
Set A1 = Range("A1")
If Intersect(Target, A1) Is Nothing Then
Else
Application.EnableEvents = False
With A1
.Offset(0, 1) = .Offset(0, 1) + .Value
.ClearContents
End With
Application.EnableEvents = True
End If
End Sub
Both sets of code work just fine to add cell A to B and reset A to zero, but I want this to work for the entire (column A and B) and all by row.
That is a picture of what I would like. I hope that this was clear and easy to understand. I appreciate any help that anyone can provide. I really appreciate it. Thank you.
Give this a try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim T As Range, r As Range
Set T = Intersect(Target, Range("A:A"))
If T Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In T
With r
.Offset(0, 1).Value = .Offset(0, 1).Value + .Value
.ClearContents
End With
Next r
Application.EnableEvents = True
End Sub