I'm trying to fire an onChange event when value entered to column A.
Now I want this, if I enter any value from Column A to Column AS, the event will fire and if I remove any value from same columns it will work as Code is written.
Also if I copy and paste a multiple data it's not working, also if I'm removing the multiple data it's not working.
Can anyone help on this? Below is the code.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim currentRow As Integer
If Not Intersect(Target, Columns("A")) Is Nothing Then
If Target.Value <> "" Then
currentRow = Target.Row
Target.Parent.Range("A" & currentRow & ":AS" & currentRow).Interior.ColorIndex = 15
Target.Parent.Range("A" & currentRow & ":AS" & currentRow).Borders.LineStyle = xlContinuous
End If
If Target.Value = "" Then
currentRow = Target.Row
Target.Parent.Range("A" & currentRow & ":AS" & currentRow).Interior.ColorIndex = 0
Target.Parent.Range("A" & currentRow & ":AS" & currentRow).Borders.LineStyle = xlNone
End If
End If
End Sub
Target.Value only has a value if a single cell is selected. If you select more than one cell it becomes an array and your If statement will always evaluate to False.
Here is one way to change your code. I was in a bit of a hurry so it could probably be done much better but should get you started.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Not Intersect(Target, Columns("A")) Is Nothing Then
If Application.WorksheetFunction.CountA(Target) = 0 Then
' Empty Range
For Each rw In Target.Rows
Target.Parent.Range("A" & rw.Row & ":AS" & rw.Row).Interior.ColorIndex = 0
Target.Parent.Range("A" & rw.Row & ":AS" & rw.Row).Borders.LineStyle = xlNone
Next rw
Else
' Not Empty
For Each rw In Target.Rows
Target.Parent.Range("A" & rw.Row & ":AS" & rw.Row).Interior.ColorIndex = 15
Target.Parent.Range("A" & rw.Row & ":AS" & rw.Row).Borders.LineStyle = xlContinuous
Next rw
End If
End If
End Sub
Related
I have the below code for entering a function and copying the orientation and borders of the above line.
But in this it only accept numeric values, how can i modify the code so that i can enter alpa numeric values in that cell.
Below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
If IsNumeric(Target.Value) Then ' Check if cell contains a numeric value
If Target.Value <> "" Then
Range("A" & Target.Row).Formula = "=IF(B" & Target.Row & "<>"""",ROW()-ROW($A$15)+1,"""")"
' Copy border, border color and orientation from row above
With Range("A" & Target.Row & ":H" & Target.Row)
.Borders.LineStyle = .Offset(-1, 0).Borders.LineStyle
.Borders.Color = .Offset(-1, 0).Borders.Color
.Orientation = .Offset(-1, 0).Orientation
End With
Else
' Check if entire row in column B is empty
If WorksheetFunction.CountA(Range("B" & Target.Row & ":H" & Target.Row)) = 0 Then
' Delete entire row
Rows(Target.Row).Delete
Else
' Clear contents of column A to H for the row where value was deleted in column B
Range("A" & Target.Row & ":H" & Target.Row).ClearContents
End If
End If
End If
End If
End Sub
Here's a small Function you could add to your code, to give it IsAlphaNumeric functionality.
Function IsAlphaNumeric(t) as Boolean
Dim i as Long
IsAlphaNumeric = True
For i = 1 To Len(t)
If Not (Mid(t, i, 1) Like "[A-z0-9]") Then
IsAlphaNumeric = False
Exit For
End If
Next
End Function
You can use it like this:
If IsAlphaNumeric(Target.Value) Then ' Check if cell contains alpha-numeric value
I have the code below which, in a simple request form, gives requestor an option to add a line for the same user.
When "Yes" is selected from a drop-down menu, a new line populates with the same Name and Alias used in the previous row, while other rows below it would move down by one row accordingly.
The code to ADD a new line (works fine) is as follows:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" & Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
End With
End Sub
I modified the above code as follows so it does remove a row below if the "No" option is selected. And it is working properly:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" & Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End With
End Sub
However, I want to make sure that a below row is deleted after selecting "No" only in cases where the below row that is to be deleted contains same data as the row above. As it is now, it removes the below line in any case, i.e. even if the requestor previously didn't click "Yes", and that's not a desired outcome.
I've been trying to modify the "No" condition as follows but still struggling:
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
If Range("A" & Target.Row & ":C" & Target.Row).Value = Range("A" & Target.Row + 1 & ":C" & Target.Row + 1).Value Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End If
Could you please help?
FOLLOW-UP:
The code I'm having now is this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
With ThisWorkbook.Worksheets("AWS Applications")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "Yes" Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Insert
.Range("A" & Target.Row & ":C" & Target.Row).Copy .Range("A" &
Target.Row + 1 & ":C" & Target.Row + 1)
Application.EnableEvents = True
End If
If Not Intersect(Target, .Range("F7:F" & LastRow)) Is Nothing And Target.Value = "No" Then
AllOk = True
For Each xCel In UpperRow.Cells
If AllOk And (xCel.Value <> xCel.Offset(1, 0).Value) Then
AllOk = False
End If
Next xCel
If AllOk Then
Application.EnableEvents = False
.Rows(Target.Row + 1).EntireRow.Delete
Application.EnableEvents = True
End If
End If
End With
End Sub
I keep getting '424' error "Object required" and the debug highlights this: For Each xCel In UpperRow.Cells
Could you please help? Apologies I'm a beginner in this...
As an indicative answer
AllOk = True
for each xCel in UpperRow.Cells
if AllOk and (xCel.Value <> xCel.Offset(1,0).Value) then
AllOk = False
End If
Next xCel
IF AllOk then
' Delete the Row
End If
You'll need to fill in some details and maybe some error checking - not a full answer
To preface the situation, I am new to VBA programming so any help would be greatly appreciated.
I have two columns; one where the user can input a dollar value ("AL") and another where the user can input a percent value ("AK"). The object is to enable the user to input either value (% or $) and have the other value calculate. For instance, if the user inputs 10% in "AL", the applicable $ value will generate in "AK" and vice versa.
Below is the code I've come up with thus far but it isn't working. Any thoughts/suggestions would be greatly appreciated! Thank you!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Set cell = Range("AK9:AL50")
'Application.EnableEvents = False Application.EnableEvents = True'
If Not Application.Intersect(cell, Range(Target.Address)) Is Nothing Then
If Target.Column = 37 Then ' Value in first column changed
Range("AL" & Target.Row).Value = Range("AK" & Target.Row).Value / Range("V" & Target.Row).Value
Exit Sub
ElseIf Target.Column = 38 Then ' value in second column changed
Range("AK" & Target.Row).Value = Range("AL" & Target.Row).Value * Range("V" & Target.Row).Value
Exit Sub
'Application.EnableEvents = False Application.EnableEvents = True'
End If
End If
End Sub
You need to remove the Exit Subs
And the Application.EnableEvents = True needs to be outside the if.
The first time you ran it with the Application.EnableEvents = False line enabled it turned off the events and since you exited the sub before turning them back on it stayed off and the sub was never called again.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Set cell = Range("AK9:AL50")
Application.EnableEvents = False
If Not Application.Intersect(cell, Range(Target.Address)) Is Nothing Then
If Target.Column = 37 Then ' Value in first column changed
Range("AL" & Target.Row).Value = Range("AK" & Target.Row).Value / Range("V" & Target.Row).Value
ElseIf Target.Column = 38 Then ' value in second column changed
Range("AK" & Target.Row).Value = Range("AL" & Target.Row).Value * Range("V" & Target.Row).Value
End If
Application.EnableEvents = True
End If
End Sub
My guess is right now your events are disabled.
Run this code after putting the correct code above in your sheet:
Sub foooo()
Application.EnableEvents = True
End Sub
This will turn the events back on. It is only needed once.
You can have a better use of your Worksheet_Change parameters, like Target.
1.Instead of:
Range("AL" & Target.Row).Value
you can use:
Target.Offset(, 1).Value
2.Instead of:
Range("AK" & Target.Row).Value
you can use:
Target.Value
3.Also Range(Target.Address) actually is Target
Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Set cell = Range("AK9:AL50")
Application.EnableEvents = False
If Not Application.Intersect(cell, Target) Is Nothing Then
If Target.Column = 37 Then ' Value in first column changed
Target.Offset(, 1).Value = Target.Value / Range("V" & Target.Row).Value
ElseIf Target.Column = 38 Then ' value in second column changed
Target.Offset(, 2).Value = Target.Value * Range("V" & Target.Row).Value
End If
End If
Application.EnableEvents = True '<-- RESTORE SETTING OUTSIDE THE IF
End Sub
Need some help with a little code.
I have created the following code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
ThisRow = Target.Row
If Target.Column = 5 Then
Range("C" & ThisRow).Value = Format(DateTime.Now, "hh:mm")
Range("D" & ThisRow).Value = Format(DateTime.Now, "mm/dd/yyyy")
Range("C:D").EntireColumn.AutoFit
End If
End Sub
Basically, if I entered information on any cell on column E, code will display "Time" in the same row on column C and "Date" on the same row on column D.
This is working fine. However, I would like to have this code deleting the information on columns C and D if the entry on columns E gets deleted and the cell is empty.
Thanks for any help in advance.
Try the code below:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim ThisRow As Long
ThisRow = Target.Row
If Target.Column = 5 Then
' if current Cell in Column E is empty, clear contents
If Range("E" & ThisRow).Value = "" Then
Range("C" & ThisRow).ClearContents
Range("D" & ThisRow).ClearContents
Else
Range("C" & ThisRow).Value = Format(DateTime.Now, "hh:mm")
Range("D" & ThisRow).Value = Format(DateTime.Now, "mm/dd/yyyy")
End If
Range("C:D").EntireColumn.AutoFit
End If
End Sub
I am able to run the validation and change event trigger to work on one cell(reference here is M6). When the user select "Valid" or "Not Valid" from the dropdown list it should populate name of the user and date in adjacent columns(N6,O6), this is working fine if I am selecting the option from drop down or copying the value one cell at a time.
Somehow the macro does not work when I copy the value in multiple cells(M8:M10) at a time, nor it is working when using the autofill option to populate records in the cells of that column. Also tried to insert a non-valid data "adsadasdad
" in Cell M8, the validation worked, but when inserting non-valid data in multiple cells, validation is not working.
Please find the macro code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
Set MainWB = ThisWorkbook
LastRow = MainWB.Worksheets("LDVC_data").Cells(MainWB.Worksheets("LDVC_data").Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If Target.Address = Range("M" & i).Address Then
If Range("M" & i) = "Valid" Or Range("M" & i) = "Not Valid" Then
ActiveSheet.Range("N" & i).Value = (Environ$("Username"))
ActiveSheet.Range("O" & i).Value = Now
ElseIf (Range("M" & i) = "[enter image description here][1]") Then
ActiveSheet.Range("N" & i).Clear
ActiveSheet.Range("O" & i).Clear
Else[enter image description here][1]
MsgBox ("Kindly enter valid value")
Range("M" & i) = ""
End If
End If
Next i
End Sub
Managed to capture the change and perform data validation in multiple cells.
Did following changes to the code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
Set MainWB = ThisWorkbook
Dim myRange As Range
Set myRange = Target
LastRow = MainWB.Worksheets("LDVC_data").Cells(MainWB.Worksheets("LDVC_data").Rows.Count, "A").End(xlUp).Row
For Each targetCell In Target
For i = 2 To LastRow
If targetCell.Address = Range("M" & i).Address Then
If Range("M" & i) = "Valid" Or Range("M" & i) = "Not Valid" Then
ActiveSheet.Range("N" & i).Value = (Environ$("Username"))
ActiveSheet.Range("O" & i).Value = Now
ElseIf (Range("M" & i) = "") Then
ActiveSheet.Range("N" & i).Clear
ActiveSheet.Range("O" & i).Clear
Else
MsgBox ("Kindly enter valid value")
Range("M" & i) = ""
End If
End If
Next i
Next targetCell
End Sub