VBA Workshhet Change - Limit the Change Just For Specific Range - excel

I have a trigger that I want to use in certain worksheet - just inside 2 specific columns. But whan I enter a value inside another range it triggers the Private Sub of that worksheet.
I want it would start to work just whan I cange value within columns E or H.
Is someone knows how to do it right?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LR As Long
Dim rng1 As Range
Dim rng2 As Range
'WE WANT TO KEEP THE TARGET COLUMNS BETWEEN 0% TO 100%
LR = Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = Intersect(Target, Range(Cells(2, "E"), Cells(LR, "E")))
On Error GoTo 1
If Target.Value < 0 Or Target.Value > 1 Then
MsgBox "bla bla bla", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "error"
Target.Value = 0
Exit Sub
End If
On Error GoTo 1
Set rng2 = Intersect(Target, Range(Cells(2, "H"), Cells(LR, "H")))
If Target.Value < 0 Or Target.Value > 1 Then
MsgBox "bla bla bla", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "error"
Target.Value = 0
Exit Sub
End If
1
End Sub

You just need to check if Target intersects with your desired range. I would Union the two columns together in this check.
As cryptically stated by DisplayName, since Target can contain more than one cell, you should check each cell in target individually. Alternatively, if your intention for Target was to always have one cell, then you can avoid the For...Each statement altogether and use this check: If Target.Cells.Count > 1 Then Exit Sub to not run the procedure when more than 1 cell is changed.
I also added another intersect target, Me.Rows("2:" & rows.count) to avoid updating any headers you may have. If your data does not contain headers, then you can remove this range from Intersect().
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo safeExit
Dim rngIntersect As Range
Set rngIntersect = Intersect(Target, Union(Me.Columns("E"), Me.Columns("H")), _
Me.Rows("2:" & Rows.Count))
If Not rngIntersect Is Nothing Then
Application.EnableEvents = False
Dim cel As Range
For Each cel In rngIntersect
If cel.Value < 0 Or cel.Value > 1 Then
MsgBox "bla bla bla", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, _
"error"
cel.Value = 0
End If
Next cel
End If
safeExit:
Application.EnableEvents = True
End Sub
As a side note, when you are using the same exact range more than once, it's not a bad idea to go ahead and set that range to a variable. So, we use rngIntersect twice in this code, so this prevents us from having to issue multiple calls to the Intersect() and Union() functions. On top of that, you run into less debugging headaches when you only have to update the range in one place rather than multiple times in your code.

The intersect can check if any of the cells in Target (yes, Target can be more than a single cell) intersect with the Union of columns E and H.
Private Sub Worksheet_Change(ByVal Target As Range)
' this next line could also be,
'If Not Intersect(Target, Range("E:E, H:H")) Is Nothing Then
If Not Intersect(Target, Union(Range("E:E"), Range("H:H"))) Is Nothing Then
On Error GoTo bye_bye
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Union(Range("E:E"), Range("H:H")))
If (t.Value2 < 0 Or t.Value2 > 1) And t.Row > 1 Then
MsgBox "bla bla bla", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "error"
t = 0
End If
Next t
End If
bye_bye:
Application.EnableEvents = True
End Sub

Related

Using target offset to clear a range of cells in excel

I'm trying to clear a range of 5 cells when changing another. For example: H5 is changed, J5:J10 is cleared. This works a treat in clearing J5 when H5 is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
If Left(Target.Address(, False), 1) = "H" Then Target.Offset(, 2).ClearContents
End Sub
However this does not clear the 4 cells below. I was wary of using a function to specify the range as I've got multiple rows of data in H. So for example if H24 changes, J24:J29 are cleared, which goes on for about 200 rows...
Any help is appreciated!
The Offset-function returns a range with the same size than the original Range, just at a different place. To increase (or decrease) the size of a range, you can use the Resize-function. So basically, you need to combine both functions.
I don't want to argue with you about how to check for the column, but I think using If Target.Column = 8 Then is much easier.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then ' Col H
Dim destRange As Range
Set destRange = Target.Offset(0, 2).Resize(5, 1)
Debug.Print destRange.Address
destRange.ClearContents
End If
End Sub
Be aware that Target may contain more than one cell (eg via Cut&Paste), you probably need to handle that.
This should do it.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(, 2), Target.Offset(5, 2)).ClearContents
Application.EnableEvents = True
End Sub
Okay with merged cells offset gets weird and even offsetting the topleft cell of the merged area (Target.MergeArea(1, 1)) will give bad results so we need to create the range ourselves.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.MergeCells = True Then
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(0, 2), ActiveSheet.Cells(Target.MergeArea(1, 1).Row + 5, Target.MergeArea(1, 1).Offset(0, 2).Column)).ClearContents
Else
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(, 2), Target.Offset(5, 2)).ClearContents
End If
Application.EnableEvents = True
End Sub
I hardcoded the 5 into the row change if you need it to be the size of the merged area you will need to get the difference in rows from the top to the bottom of the merged area.
Clear Cells on Any Side of Merged Cells
The colors in the image show which contents will be cleared in column J if a value in a cell in column H is changed (manually or via VBA).
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim doEnableEvents As Boolean
On Error GoTo clearError
Const FirstCellAddress As String = "H2"
Const ColOffset As Long = 2
Dim irg As Range
With Range(FirstCellAddress)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
End With
If Not irg Is Nothing Then
Application.EnableEvents = False
doEnableEvents = True
Dim arg As Range
Dim cel As Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If cel.MergeCells Then
With cel.MergeArea
.Cells(1, 1).Offset(, ColOffset).Resize(.Rows.Count) _
.ClearContents
End With
Else
cel.Offset(, ColOffset).ClearContents
End If
Next cel
Next arg
End If
ProcExit:
If doEnableEvents Then
Application.EnableEvents = True
End If
Exit Sub
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
Sub testMultiArea()
Dim rg As Range: Set rg = Range("H2,H7")
rg.Value = 500
End Sub

Decimal data validation using macros

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

Excel VBA Error in comparing two cells for dates

In my sheet columns B:C allow dates. I'm trying to create a check to see whether a date entered in C is more recent than B, if so fine, else alert the user and clear contents.
My code returns a run-time error 91 in the application.intersect line:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dates As Range
Set Dates = Range("C4:C12")
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Not Application.Intersect(Dates, Range(Target.Address)).Value > ActiveCell.Offset(0, -1).Value Then
GoTo DatesMissMatch
Else
Exit Sub
End If
DatesMissMatch:
Target.ClearContents
ActiveCell.Value = "A2"
MsgBox "Please re-check dates"
End Sub
I changed your method, but this seems to be working.
I also noticed that you were writing A2 to ActiveCell instead of Target. Did you want the cell in column C to update if invalid data is entered or did you intend for it to be whichever cell you move to that gets changed?
At any rate, here's a way I came up with it
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Target.Column = 3 Then 'Check to see if column C was modified
If Target.Value < Target.Offset(0, -1).Value Then
Target.ClearContents
Target.Value = "A2"
MsgBox "Please re-check dates"
End If
End If
End Sub
If you want to stick with the way you are currently doing it, then I think you need to check that the Intersection is not empty as another answer concludes.
I believe you just have to check the intersect than do the compare.
Sub Worksheet_Change(ByVal Target As Range)
Dim Dates As Range
Set Dates = Range("C4:C12")
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Not Application.Intersect(Dates, Range(Target.Address)) Is Nothing Then
If Target.Value < Target.Offset(0, -1).Value Then
GoTo DatesMissMatch
Else
Exit Sub
End If
End If
DatesMissMatch:
Target.ClearContents
ActiveCell.Value = "A2"
MsgBox "Please re-check dates"
End Sub
You can just loop the rows and compare the dates.
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
Dim lRow As Long
lRow = 4
Do While lRow <= ws.UsedRange.Rows.count
If ws.Range("C" & lRow).Value > ws.Range("B" & lRow).Value then
GoTo DatesMissMatch
End if
lRow = lRow + 1
Loop

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

Insert data in same row when a value in a cell is changed

I have code that retrieves information from SQL and VFP and populates a dropdown list in every cell in column "A" except A1 - this is a header.
I need to populate the "G" column on the row where the user selects the value from a dropdown in the "A" column.
I believe I need to be in Private Sub Worksheet_SelectionChange(ByVal Target As Range) which is in the sheet object.
Below is something similar to what I want to do.
If cell "a2".valuechanged then
Set "g2" = "8000"
End if
If cell "a3".valueChanged then
Set "g3" = "8000"
End if
The code above doesn't work, but I think it is easy to understand. I want to make this dynamic, so I don't have too many lines of code.
I have already explained about events and other things that you need to take care when working with Worksheet_Change HERE
You need to use Intersect with Worksheet_Change to check which cell the user made changes to.
Is this what you are trying?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if user has selected more than one cell
If Target.Cells.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
'~~> Check if the user made any changes in Col A
If Not Intersect(Target, Columns(1)) Is Nothing Then
'~~> Ensure it is not in row 1
If Target.Row > 1 Then
'~~> Write to relevant cell in Col G
Range("G" & Target.Row).Value = 8000
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Try this
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column <> 7 Then
Cells(Target.Row, "G").Value = 8000
End If
End Sub
If you only need it to fire on column A then
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column = 1 Then
Cells(Target.Row, "G").Value = 8000
End If
End Sub
can you not put an if statement in column G , as in
If (A1<>"", 8000,0)
Other wise something like this will get you going:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 1 Then
If Target.Value2 <> "" Then
Target.Offset(0, 6) = "8000"
Else
Target.Offset(0, 6) = ""
End If
End If
On Error GoTo 0
End Sub
Thanks
Ross
I had a similar problem. I used Siddharth Rout's code. My modifications allow a user to paste a range of cells in column a (ex. A3:A6) and have multiple cells modified (ex. H3:H6).
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if user has selected more than one cell
If Target.Cells.CountLarge < 1 Then Exit Sub
If Target.Cells.CountLarge > 500 Then Exit Sub
Debug.Print CStr(Target.Cells.CountLarge)
Application.EnableEvents = False
Dim the_row As Range
Dim the_range As Range
Set the_range = Target
'~~> Check if the user made any changes in Col A
If Not Intersect(the_range, Columns(1)) Is Nothing Then
For Each the_row In the_range.Rows
'~~> Ensure it is not in row 2
If the_row.Row > 2 Then
'~~> Write to relevant cell in Col H
Range("H" & the_row.Row).Value = Now
End If
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub

Resources