Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("d10:e309")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
With Range("d10:e309")
Select Case .Value2
Case 0
'do nothing
Case 1
.Value = 0.01
Case 5
.Value = 0.005
End Select
End With
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
I'm wanting the code to use 1 and 5 when inputted into a cell to act as shortcuts to automatically be replaced in the cell inputted in with .01 and .005 respectively
Range("d10:e309").Value2 will be an array. Comparing an array to a value doesn't work. Secondly Target.Value may be an array too, if more than one cell is changed, eg by copy paste. It also may include cells outside your range of interest
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TargetRange As Range, rng As Range
Set TargetRange = Intersect(Target, Range("d10:e309"))
If Not TargetRange Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each rng In TargetRange
Select Case rng.Value2
Case 0
'do nothing
Case 1
Rng.Value = 0.01
Case 5
Rng.Value = 0.005
End Select
Next
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
Related
I want a macro that automatically multiplies a given column by a set number. This number will be different for each column. I am only able to apply it to one column so far. I can't have it done for any other:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = Target.Value * 300
Application.EnableEvents = True
If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = Target.Value * 500
Application.EnableEvents = True
End Sub
Perhaps like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo SafeExit
Application.EnableEvents = False
Dim rng As Range
Set rng = Intersect(Target, Me.Range("B:B")
If Not rng Is Nothing Then
rng.Value = rng.Value * 300
End If
Set rng = Intersect(Target, Me.Range("C:C"))
If Not rng Is Nothing Then
rng.Value = rng.Value * 500
End If
SafeExit:
Application.EnableEvents = True
End Sub
EDIT:
This is probably a better approach if you have more than two columns (and they are contiguous):
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B:F")) Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
Dim rng as Range
For Each rng In Intersect(Target, Me.Range("B:F"))
Dim multiplier As Long
Select Case rng.Column
Case 2 ' column B
multiplier = 300
Case 3 ' column C
multiplier = 500
Case 4 ' column D
multiplier = 400
Case 5 ' column E
multiplier = ...
Case 6 ' column F
multiplier = ...
End Select
If IsNumeric(rng.Value) Then
rng.Value = rng.Value * multiplier
End If
Next
End If
SafeExit:
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 have a VBA like below but when i copy more then 1 cell i get a error because of the multiple selection.
Is it possible to make a action that the Case looks at the selected cells one after the other? Or do i have the wrong Statment?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$G$8:$OA$92")) Is Nothing Then
With Target
Select Case .Value
Case Is = "Weekend"
.Interior.ColorIndex = 48
Case Is = "VRIJ", "ADV"
.Interior.ColorIndex = 6
End Select
End With
End If
End Sub
Loop through the cells in the intersect.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("G8:OA92")) Is Nothing Then
on error goto meh
application.enableevents = false
dim t as range
for each t in Intersect(Target, Range("G8:OA92"))
With t
Select Case lcase(.Value2)
Case "weekend"
.Interior.ColorIndex = 48
Case "vrij", "adv"
.Interior.ColorIndex = 6
case else
.interior.pattern = xlnone
End Select
End With
next t
End If
meh:
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 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