Can someone please help me with this code. It will insert the current date in H if I do any changes to I.
My problem is that this will not work if for example I fill in I1 with something, and then I drag down for copying in many cells at once. If for example I copy value from I1 once at a time in each cell( I2,I3 ETC) it will work.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("I:I")) Is Nothing) Then _
Target.Offset(0, -1) = Date
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("I:I10"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, -1) = Date
Next
End If
Application.EnableEvents = True
End If
End Sub
Thank you !
Avoid the unnecessary use of On Error Resume Next. Handle the Error gracefully. I recommend reading THIS once when using Worksheet_Change
Also you have If (Target.Count = 1) Then because of which your code doesn't execute. When you drag, the count increases.
Is this what you are trying?
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Dim aCell As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("I:I")) Is Nothing Then
For Each aCell In Target
'~~> Additional blank check for I. So that the date
'~~> is not inserted if the value is deleted. Remove this
'~~> if you want the date to be inserted even when the value is deleted
If Len(Trim(aCell.Value)) <> 0 Then
Range("H" & aCell.Row).Value = Date
Else
'Remove Date?
End If
Next aCell
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
In action:
Related
I have problem in my code, i need to change in another column - row
I tried to built macro but it's dosn't work with that.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range
On Error Resume Next
Set xRg = Intersect(Target, Range("A6:U1000"))
If xRg Is "YES" Then Exit Sub
Range("G" & Target.Row).Value = "CHECK"
End Sub
When in column N6:N1000 is "YES" in Column G change value to "Check" and all row A6 for example to U1000 is in color red
I can't quite understand what you're trying to achieve here, but hopefully the below will be doing roughly what you need. Try it and let me know if it doesn't behave the way you hope.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim xRg As Range, cl as Range
Set xRg = Intersect(Target, Range("A6:U1000"))
If Not xRg Is Nothing Then
For Each cl In xRg.Cells
If cl.Value = "YES" Then Range("G" & cl.Row).Value = "CHECK"
Next
End If
Application.EnableEvents = True
End Sub
I have a macro enabled work sheet in which i have data validations for columns where i want to regulate the data input. I cannot use regular data validation feature in excel as it fails to function as we copy data from other sources which is the case in my requirement.So i am implementing data validations through macros . I have a scenario where one column can input only decimal data. The conditions are as follows the input data is of length 9 which constitutes only 2 decimal positions. I have partly written a macro for this validation which does not work(When i make a invalid input macro is not triggered therefore no msgbox pop up) and i am stuck at this point.Please help me out here to find a different if condition for the validation. The macro i have written is as follows:
Set AffectedCells = Intersect(Target, Target.Parent.Range("F:F"))
If Not AffectedCells Is Nothing Then
For Each Cell In AffectedCells
If Not (Cell.Value * (10 ^ 2) Mod 10) <> 0 Then
MsgBox "The value you entered is not valid."
Application.Undo 'undo insert
Exit Sub 'stop checking after one invalid data was found.
End If
This needs to be pasted on the sheet code space for the sheet you want the macro to run on.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCell As Range, AffectedCells As Range
Set AffectedCells = Intersect(Target, Target.Parent.Range("F:F"))
If Not AffectedCells Is Nothing Then
For Each xCell In AffectedCells
If Not (xCell.Value * (10 ^ 2) Mod 10) <> 0 Then
MsgBox "The value you entered is not valid."
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Exit Sub
End If
Next xCell
End If
End Sub
Is this what you are trying? I have commented the code so you should not have a problem undrstanding it. But if you do then simply ask.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCell As Range, AffectedCells As Range
On Error GoTo Whoa
Application.EnableEvents = False
Set AffectedCells = Intersect(Target, Columns(6))
If Not AffectedCells Is Nothing Then
For Each xCell In AffectedCells
'~~> Avoid cases like IP address 10.1.2.234
'~~> Check if the number contains decimal
If IsNumeric(xCell.Value) And _
Int(xCell.Value) <> xCell.Value Then
'~~> Check the position of the decimal
'~~> Check the length of the string
If Mid(xCell.Value, Len(xCell.Value) - 2, 1) <> "." Or _
Len(xCell.Value) > 9 Then
'
'~~> INVALID INPUT: Do what you want
'
'MsgBox "The value you entered is not valid."
'Application.Undo
'Exit For
End If
End If
Next xCell
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
I am trying to run this worksheet change event for two different columns(A) and (I)...
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
r.Offset(0, 1).Value = Date
Next r
Application.EnableEvents = True
End Sub
This event is something i found on this forum. Its purpose is to make it so whenever data is ever entered into column "a" it auto inputs the date into the cell directly right of it. I want this to happen twice on the worksheet. I can't figure out how to change/add to it. I am trying to get it to run the logic for column A and I on my spreadsheet.
Just expand the range you set to the A variable.
Set A = Range("A:A, I:I")
Rewritten as,
Private Sub Worksheet_Change(ByVal Target As Range)
if not intersect(range("A:A, I:I"), target) is nothing then
'add error control
on error goto safe_exit
'don't do anything until you know something has to be done
dim r as range
Application.EnableEvents = False
For Each r In intersect(range("A:A, I:I"), target)
r.Offset(0, 1).Value = Date 'do you want Date or Now?
Next r
end if
safe_exit:
Application.EnableEvents = True
End Sub
edited after OP's comment
expanding on #Jeeped solution, you can avoid looping:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Range("A:A, I:I"), Target) ' define range of interest
If Not rng Is Nothing Then ' check it's not "nothing"
If WorksheetFunction.CountA(rng) = rng.Count Then 'check for all of its cells being not empty
On Error GoTo safe_exit 'add error control
Application.EnableEvents = False 'don't do anything until you know something has to be done
rng.Offset(, 1).Value = Date 'write Date next to all relevant changed cells
End If
End If
safe_exit:
Application.EnableEvents = True
End Sub
Got a problem and looking for some advice. I've been using the below code for a while now in Excel, it clears the contents of column B if cell A is empty. It works great, but I now need it to work for a specific range (A6:B35). Any ideas?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 1 Then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
End Sub
You need to test if the active cell (target) falls in the range A6:A35. Like this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If not intersect(target, range("A6:A35")) is nothing then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
Application.EnableEvents = True
End If
End if
exitHandler:
End Sub
You should also indent your code so it is more readable. It will help with loops and IF statements.
something like
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Target, Range("A6:B35"))
If rng1 Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each rng2 In rng1
If rng2.Validation.Type = 3 Then rng2.Offset(0, 1).ClearContents
Next
Application.EnableEvents = True
End Sub
I have a code in Worksheet_Change
If a column 9 is updated then the column 8 will be automatically populated by multiplying with col 9 and col 11.
But when the user pastes the values in the column, the change event does not work correctly. Only the first cell in the Col 8 gets updated.
How can I overcome from this?
Try this
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
If Target.Columns.Count > 1 Then GoTo LetsContinue
If Not Intersect(Target, Columns(9)) Is Nothing Then
Dim aCell As Range
For Each aCell In Target
aCell.Offset(, -1).Value = aCell.Value * aCell.Offset(, 2)
Next
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub