Hi I have the following code , what I need is line 6,7 and 8 to work together, by which I mean:
When a cell in H is changed it finds the next empty column which works fine but if more than one cell is copied and pasted it only enters the data in one cell!
If I use line 6 and not line 7 it puts data in all the cells but will not find next empty cell.
How can I combine the two?
1. Private Sub worksheet_change(ByVal Target As Range)
2. On Error GoTo errHandler:
3. If Not Intersect(Range("A:A,H:H"), Target) Is Nothing Then
4. If WorksheetFunction.CountA(Target) Then
5. Application.EnableEvents = False
6. 'Target.Offset(, 4) = Environ("username") & "-" & Date
7. Cells(Target.Row, Cells(Target.Row,
Columns.Count).End(xlToLeft).Column + 1).Value = _
8. Environ("username") & "-" & Date
9. End If
10. End If
11. errHandler:
12. Application.EnableEvents = True
13. If Err.Number Then Err.Raise Err.Number
14. End Sub
I think you want the following:
Private Sub worksheet_change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo errHandler:
Dim targetcell As Range
For Each targetcell In Target.Cells
If Not Intersect(Range("A:A,H:H"), targetcell) Is Nothing Then
If WorksheetFunction.CountA(targetcell) Then
Cells(targetcell.Row, Cells(targetcell.Row, Columns.count).End(xlToLeft).Column + 1).Value = _
Environ("username") & "-" & Date
End If
End If
Next
errHandler:
Application.EnableEvents = True
If Err.Number Then Err.Raise Err.Number
End Sub
Related
what am I doing wrong here...please help, thanks PG
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ValidatedCells As Range
Dim ValidatedCells2 As Range
Dim Cell As Range
Set ValidatedCells = Intersect(Target, Target.Parent.Range("G:G"))
Set ValidatedCells2 = Intersect(Target, Target.Parent.Range("H:H"))
Application.EnableEvents = False
If Not ValidatedCells Is Nothing Or Not ValidatedCells2 Is Nothing Then
For Each Cell In ValidatedCells
If Not Len(Cell.Value) <= 20 Then
MsgBox "The Name """ & Cell.Value & _
""" inserted in " & Cell.Address & _
" in column G was longer than 20. Undo!", vbCritical
Application.Undo
End If
Next Cell
For Each Cell In ValidatedCells2
If Not Len(Cell.Value) <= 50 Then
MsgBox "The Name """ & Cell.Value & _
""" inserted in " & Cell.Address & _
" in column H was longer than 50. Undo!", vbCritical
Application.Undo
Next Cell
Exit Sub
End If
Application.EnableEvents = True
End Sub
I tried above and not sure if it is the syntax or if the loop statements are incorrect, please help
A few issues in your code - after calling Undo there's no point in continuing, so you can just exit at that point. Needs some error handling to make sure Events are not left turned off.
I'd maybe do something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo done
If TooLong(Intersect(Target, Me.Range("G:G")), 20) Then GoTo done
If TooLong(Intersect(Target, Me.Range("H:H")), 50) Then GoTo done
done:
If Err.Number <> 0 Then MsgBox Err.Description 'in case of error
Application.EnableEvents = True
End Sub
'If any cell in range `Monitored` has content longer than `maxLen`,
' call Undo and return True
Function TooLong(Monitored As Range, maxLen As Long) As Boolean
Dim c As Range
If Not Monitored Is Nothing Then
For Each c In Monitored.Cells
If Len(c.Value) > maxLen Then
MsgBox "The Name """ & c.Value & """ inserted in " & c.Address & _
" in column was longer than " & maxLen & ". Undo!", vbCritical
Application.EnableEvents = False
Application.Undo
TooLong = True
Exit Function
End If
Next c
End If
End Function
Note: in a worksheet code module you can use Me to refer to the worksheet, instead of Target.Parent
Advice would be gratefully appreciated. I am developing a spreadsheet using Excel 2016/Windows.
I have written 4 eventchange subroutines and all work well. The VBA Code for a worksheet checks for 4 events. Event 1, 2 and 3 enter today's date in a cell if data is entered in another cell (code not included below)
Code for EventChange works fine, but sometimes works when not expected to!
EventChange4 moves a value from one cell to another if another cell contains the text in Column J is "THIS Month – Payment Due" or "Issued But Not Paid. The second part of this eventchange4 moves a zero value to 2 cells if the data in column j contains text "not going ahead"
I am new to VBA. The problem is that eventchange4 runs for no apparent reason, e.g. copying a cell value in column H down to another cell in column h. How can I modify the code such that that eventchange4 only runs when the data in Column J Changes??? All advice gratefully accepted!!!!
Private Sub Worksheet_Change(ByVal Target As Range)
Call EventChange_1(Target)
Call EventChange_2(Target)
Call EventChange_3(Target)
Call EventChange_4(Target)
End Sub
Sub EventChange_1(ByVal Target As Range)
'Update on 11/11/2019 -If data changes in column L, insert
'today's date into column M
End Sub
Sub EventChange_2(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column P, insert today's date
'into next Column Q
End Sub
Sub EventChange_3(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column R, insert today's date
'into next Column S
End Sub
Sub EventChange_4(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
' this works !
If Target.Column = 10 And (Target.Value = "THIS Month – Payment Due" Or Target.Value = "Issued But Not Paid") Then
Range("K" & Target.Row).Value = Range("I" & Target.Row).Value
Range("I" & Target.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If Target.Column = 10 And (Target.Value = "Not Going Ahead") Then
Range("I" & Target.Row).Value = 0
Range("K" & Target.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Application.EnableEvents = True
End Sub
Ideally you should update your code so it can properly handle a Target range which is not just a single cell:
Sub EventChange_4(ByVal Target As Range)
Dim rng As Range, c As Range, v
'any part of Target in Column J?
Set rng = Application.Intersect(Target, Me.Columns(10))
If Not rng Is Nothing Then
'have some cells to process...
On Error GoTo haveError
Application.EnableEvents = False
'process each affected cell in Col J
For Each c In rng.Cells
v = c.Value
If v = "THIS Month – Payment Due" Or v = "Issued But Not Paid" Then
Range("K" & c.Row).Value = Range("I" & c.Row).Value
Range("I" & c.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If v = "Not Going Ahead" Then
Range("I" & c.Row).Value = 0
Range("K" & c.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Next c
End If
haveError:
Application.EnableEvents = True
End Sub
NOTE: this is assumed to be in the relevant worksheet code module - otherwise you should qualify the Range() calls with a specific worksheet reference.
All your "change" handlers should follow a similar pattern.
Tim apologies. I am new to this and was anxious to get a solution. Thank you for your response. Advice Noted. T
When I attempt to insert or delete a row in the spreadsheet, the VBA code identifies a worksheet event and attempts to run the code. The spreadsheet crashes. I have attempted to add code that will prevent this by checking at the beginning of the module if a row has been inserted or deleted before the other worksheet change event if statements are checked
Thank you
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
Dim wsInc As Worksheet
Dim count As Integer
Dim lRow As Long
Dim ans As Variant
Dim tb As ListObject
On Error GoTo Whoa
Application.EnableEvents = False
Set tb = ActiveSheet.ListObjects(1)
MsgBox Target.Rows.count
If tb.Range.Cells.count > count Then
count = tb.Range.Cells.count
' GoTo Whoa
ElseIf tb.Range.Cells.count < count Then
count = tb.Range.Cells.count
' GoTo Whoa
'~~> Check if the change happened in Col A
ElseIf Not Intersect(Target, Columns(1)) Is Nothing Then
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
Next
'~~> Check if the change happened in Col L
ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
Set wsInc = Sheets("Income")
lRow = wsInc.Range("A" & wsInc.Rows.count).End(xlUp).Row + 1
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'~~> Check of the value is Fees Received, Policy No. Issued
If .Value = "Fees Received" Or .Value = "Policy No. Issued" Then
ans = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)
If ans = False Then Exit For
wsInc.Range("A" & lRow).Value = Range("A" & aCell.Row).Value
End If
End If
End With
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
I have a file where I want to check if cell "$A$2" is empty and if that's true I want to add the formula (=VLOOKUP($I$2;'Raw Data'!$A$1:$AH$5000;4;FALSE) in this cell. Went I run the code below it generates a
Run-tim error '1004' (Application-defined or object defined error).
I already played with the target formula and if I take simple formulas like =B1+B2 it works and I don^t get an error message. So it seems to be something about the Vlookup formula that causes the error.
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Cells.Address = "$A$2" And Target = vbNullString) Then
Target.Formula = "=VLOOKUP($I$2;'Raw Data'!$A$1:$AH$5000;4;FALSE)"
End If
End Sub
I expect the cell "$A$2" to show the result of the formula =VLOOKUP($I$2;'Raw Data'!$A$1:$AH$5000;4;FALSE) unless the cell is overwritten manually.
Thanks for your help #Pᴇʜ #eirikduade #Gareth!
Now I am trying to do the same for all cells in Column A where there is a value in column I of the same row and I struggle with the .Range function. Could you please give me any suggestions how to fix the following code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRowF As Integer
lastRowF = Sheet3.Cells(Sheet3.Rows.Count, "I").End(xlUp).Row
For j = 1 To lastRowF
If Intersect(Target, Me.Range(Cells(j, 2))) Is Nothing Then Exit Sub
If Me.Range(.Cells(j, 2)) = vbNullString Then
Me.Range(.Cells(j, 2)).Formula = "=VLOOKUP(""" & cells.(y, 1) & """,'Raw Data'!$A$1:$AH$5000,4,FALSE)"
Exit For
End If
Next j
End Sub
The main issue
You need to switch the ; to , because the .Formula needs to be the original english version of the formula which uses ,.
Your code will fail if Target is a range of multiple cells
Note that your code will fail if you eg. copy paste a range (not a single cell).
Change it to the following:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("A2")) Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error Goto ENABLE_EVENTS
If Me.Range("A2").Value = vbNullString Then
Me.Range("A2").Formula = "=VLOOKUP($I$2,'Raw Data'!$A$1:$AH$5000,4,FALSE)"
End If
ENABLE_EVENTS:
Application.EnableEvents = True
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
If you need to do it for multiple cells in column A it would look like this:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Range("A2:A" & Me.Rows.Count))
Application.EnableEvents = False
On Error Goto ENABLE_EVENTS
If Not AffectedRange Is Nothing Then
Dim iCell As Range
For Each iCell In AffectedRange.Cells
If iCell.Value = vbNullString Then
iCell.Formula = "=VLOOKUP($I" & iCell.Row & ",'Raw Data'!$A$1:$AH$5000,4,FALSE)"
End If
Next iCell
End If
ENABLE_EVENTS:
Application.EnableEvents = True
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
Note that you probably mean to use
"=VLOOKUP($I" & iCell.Row & ", 'Raw Data'!$A$1:$AH$5000,4,FALSE)"
instead of
"=VLOOKUP($I$2, 'Raw Data'!$A$1:$AH$5000,4,FALSE)"
In VBA code, you must use commas to separate arguments in functions, even if your local delimiter is semi-colons.
I.e. change the line
Target.Formula = "=VLOOKUP($I$2;'Raw Data'!$A$1:$AH$5000;4;FALSE)"
to
Target.Formula = "=VLOOKUP($I$2,'Raw Data'!$A$1:$AH$5000,4,FALSE)"
and see if that works
hi I have a code to delete entire row if cell in column G ="YES". It works fine, but when copy cells from one workbook to another it deletes the last row that is paste. Same as if I drag cell to auto fill.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
'If Cell that is edited is in column U and the value is completed then
If Target.Column = 7 And Target.Value = "YES" Then
'Define last row on completed worksheet to know where to place the row of data
LrowCompleted = Sheets("EQUIP. OFF RENT").Cells(Rows.Count, "A").End(xlUp).Row
'Copy and paste data
Range(Target.Row & ":" & Target.Row).Copy Sheets("EQUIP. OFF RENT").Range("A" & LrowCompleted + 1)
End If
If Target.Column = 7 And Target.Value = "YES" Then
Range(Target.Row & ":" & Target.Row).Delete
End If
Application.EnableEvents = True
After analyzing your code, it's a classical problem with the On Error Resume Next, combined with the Application.EnableEvents = False.
Even if there is an error in the code, the job is still running. That's why the last cell is deleted after a paste for example.
To avoid this, i simply erase the error resume next and the enableevents, and add this line before the first If statement :
If Target.Column = 1 Then Exit Sub
So please try this :
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then Exit Sub
If Target.Column = 7 And Target.Value = "YES" Then
'Define last row on completed worksheet to know where to place the row of data
LrowCompleted = Sheets("EQUIP. OFF RENT").Cells(Rows.Count, "A").End(xlUp).Row
'Copy and paste data
Range(Target.Row & ":" & Target.Row).Copy Sheets("EQUIP. OFF RENT").Range("A" & LrowCompleted + 1)
End If
If Target.Column = 7 And Target.Value = "YES" Then
Range(Target.Row & ":" & Target.Row).Delete
End If
End Sub
I am writing code which compares date entered in one column to date in another column. An error message is displayed if the entry violates data validation rules.
Also, I have disabled cut-paste operation and ctl+d.
Data Validation rules:
Enter valid date between 01/01/1900 and 12/31/9999
Date value in Column AP should be greater than Column AO.
But, when a user copies a cell, selects multiple cells in the target column and pastes, then data validation doesn't trigger at all. Below is the screenshot:
The below code handles single cell operations like copying a cell and paste in another cell but not able to handle when a user selects more than one cell and pastes.
Please help me understand as what is wrong with my code. Thank you!
Here is my code:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrorHandler
Dim lstrow As Long
lstrow = Range("A" & Rows.Count).End(xlUp).Row
If Intersect(Target, Range("AP5:AP" & lstrow - 1)) Is Nothing Then Exit Sub
If Target.Value <> "" And Target.Value <= Range("AO" & Target.Row) Then
Application.EnableEvents = False
Target.Value = ""
MsgBox ("The date you have entered is either not in correct format OR less than date in column AO")
Else: Target.NumberFormat = "dd-mmm-yyyy"
End If
ErrorExit:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Debug.Print Err.Number & vbNewLine & Err.Description
Resume ErrorExit
End Sub
I tried the below code but it didn't work.
if Target.cells.count > 1 then
msgbox("Select a single cell to paste")
ActiveCell.Select
end if
'========================================================================
I have encountered another issue. Now, I want to evaluate one more column in the same worksheet under worksheet_change event. But, code for only one column is getting evaluated and not the other column.
Please advise.
Here is my updated code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Added to define the last row by locating the text string (blank)
On Error GoTo ErrorHandler
Dim lstrow As Long
'ActiveRow = ActiveCell.Row
lstrow = Range("A" & Rows.Count).End(xlUp).Row
If Intersect(Target, Range("AP5:AP" & lstrow)) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then
Application.EnableEvents = False
Application.Undo
MsgBox "Select only single cell to paste"
ActiveCell.Select
Application.CutCopyMode = False
Application.EnableEvents = True
Exit Sub
End If
If Target.Value <> "" And Target.Value <= Range("AO" & Target.Row) Then
Application.EnableEvents = False
Target.Value = ""
MsgBox ("The date you have entered is either not in correct format OR less than Column AO")
Else: Target.NumberFormat = "dd-mmm-yyyy"
Application.EnableEvents = True
Exit Sub
End If
'----------------------------------------------------------------------------------
If Intersect(Target, Range("AL5:AL" & lstrow)) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then
Application.EnableEvents = False
Application.Undo
MsgBox "Select only single cell to paste"
ActiveCell.Select
Application.CutCopyMode = False
Application.EnableEvents = True
Exit Sub
End If
If Target.Value <> "" And Target.Value <= Range("AK" & Target.Row) Then
Application.EnableEvents = False
Target.Value = ""
MsgBox ("The value you entered is less than the value in column AK")
Else: Target.NumberFormat = "0.00"
Application.EnableEvents = True
Exit Sub
End If
'----------------------------------------------------------------------------------
ErrorExit:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Debug.Print Err.Number & vbNewLine & Err.Description
Resume ErrorExit
End Sub
Can we evaluate two different ranges in the same worksheet_change event?
screenshot of the worksheet after the code is run:
After the line
If Intersect(Target, Range("AP5:AP" & lstrow - 1)) Is Nothing Then Exit Sub
Try inserting this additional checking:
If Target.Cells.Count > 1 Then
Application.EnableEvents = False
Application.Undo
msgBox "entering many cells simultaneously in column AP is not allowed"
Application.EnableEvents = True
Exit Sub
End If