I made a VB makro in Excel to execute something if the cell is in a given range but when I execute it it gives me an error and I don't see why.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim isect As Boolean
isect = Application.Intersect(Selection, Range("D11:D35"))
If isect Then
If ActiveCell.Offset(-1, 0) - ActiveCell.Offset(-1, 1) > 2.5 Then
Range("A1:A1").Value = "ok"
End If
End If
End Sub
The error is:
Object variable or With block variable not set.
Change the first 3 lines into:
Dim isect As Range
Set isect = Application.Intersect(Selection, Range("D11:D35"))
If Not isect Is Nothing Then
but check also comment from #Siddharth about looping which is very important here.
Another way without using a Boolean Variable / Selection (Also Incorporating Tim's suggestion as well)...
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
If Target.Cells.CountLarge > 1 Then
MsgBox "More than 1 cell ws changed"
Else
If Not Intersect(Target, Range("D11:D35")) Is Nothing Then
If Target.Offset(-1, 0).Value - Target.Offset(-1, 1).Value > 2.5 Then
Range("A1").Value = "ok"
End If
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Note: Why .CountLarge? See this
Related
I have a problem with VBA, I need to use the worksheet change event to pickup cell values from AI28 to AI30 and move them over to V28 to V30. This is what I have do so far
Private Sub Worksheet_Change(ByVal Target As Range)
If IsNumeric(Target) And Not (Target = "") Then
If Target.Address = Range("AI28:AI30").Address Then
Range("V28:V30").Value = Range("AH28:AH30").Value
Else
If Target.Cells.Value <> Empty Then Exit Sub
Exit Sub
End If
End If
End Sub
It works fine for just one range eg AI28 and V28 so what am I missing? A loop or something?
Use a loop and Intersect:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Target, Me.Range("AI28:AI30"))
If rng Is Nothing Then Exit Sub
On Error GoTo SafeExit
Application.EnableEvents = False
Dim cell As Range
For Each cell In rng
If IsNumeric(cell.Value) And Not IsEmpty(cell.Value) Then
Me.Range("V" & cell.Row).Value = cell.Value
End If
Next
SafeExit:
Application.EnableEvents = True
End Sub
I'm trying to verify a range of cells from M31:M41 and if the cells are grey and a user enters in information by mistake, then a message box appears and then the last action is undone. Here's my code so far
Set rng = ThisWorkbook.Sheets("Edit Entry").Range("M31:M41")
For each cell in rng
If cell.interior.Colorindex = 15 then
If Not Intersect(Target, Range("M31:M41")) Is Nothing then
Msgbox "NOT AN EDITABLE FIELD.", vbCritical + vbOkOnly, "NO DATA ENTRY"
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
Next Cell
The issue, is that it works how I want it to but it gives me the error
Run-Time error '1004': Method 'Undo' of object' _Application' Failed.
Any ideas on how to achieve this without any coding issues?
This seems to work for me for a single cell....
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
Set myRange = Range("M31:M41")
If Not Intersect(Target, myRange) Is Nothing Then
If Target.Interior.Color = 15 Then
Application.EnableEvents = False
MsgBox "Cannot Change This Cell"
Application.Undo
Application.EnableEvents = True
End If
End If
End Sub
And for a multi-ranged change...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range, xCell As Range
Set myRange = Range("M31:M41")
For Each xCell In Target
If Not Intersect(xCell, myRange) Is Nothing Then
If xCell.Interior.Color = 15 Then
Application.EnableEvents = False
MsgBox "Cannot Change This Cell"
Application.Undo
Application.EnableEvents = True
Exit Sub
End If
End If
Next xCell
End Sub
I want to merge two Worksheet_Change events.
The aim of the code is to convert any uppercase text in the cell ranges given to lowercase.
I tried copying both into the same Worksheet_Change, but Excel crashed.
Range 1:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ccr As Range
Set ccr = Range("C6")
For Each Cell In ccr
Cell.Value = LCase(Cell)
Next Cell
End Sub
Range 2:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim acr As Range
Set acr = Range("C9:G9")
For Each Cell In acr
Cell.Value = LCase(Cell)
Next Cell
End Sub
The main issue is that changing a cell value Cell.Value will trigger another Worksheet_Change immediately. You need to Application.EnableEvents = False to prevent this.
Also I recommend to work with Intersect so the code only runs on the cells that are actually changed.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Target.Parent.Range("C6, C9:G9"))
If Not AffectedRange Is Nothing Then
Application.EnableEvents = False 'pervent triggering another change event
Dim Cel As Range
For Each Cel In AffectedRange.Cells
Cel.Value = LCase$(Cel.Value)
Next Cel
Application.EnableEvents = True 'don't forget to re-enable events in the end
End If
End Sub
In addition to #Frank Ball's comment including error handling:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Target.Parent.Range("C6, C9:G9"))
Application.EnableEvents = False 'pervent triggering another change event
On Error GoTo ERR_HANDLING
If Not AffectedRange Is Nothing Then
Dim Cel As Range
For Each Cel In AffectedRange.Cells
Cel.Value = LCase$(Cel.Value)
Next Cel
End If
On Error GoTo 0
'no Exit Sub here!
ERR_HANDLING:
Application.EnableEvents = True
If Err.Number <> 0 Then
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Sub
Like this you can do both the things in same event
You have to add Application.EnableEvents = False at the starting to avoid race condition.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim ccr As Range, acr as Range
Set ccr = Range("C6")
For Each Cell In ccr
Cell.Value = LCase(Cell)
Next Cell
Set acr = Range("C9:G9")
For Each Cell In acr
Cell.Value = LCase(Cell)
Next Cell
Application.EnableEvents = True
End Sub
The two Worksheet_Change events are quite the same, they are a loop around a range, returning LCase(). Thus, it is a good idea to make a separate Sub for it like this:
Sub FixRangeLCase(rangeToFix As Range)
Dim myCell As Range
For Each myCell In rangeToFix
myCell.Value2 = LCase(myCell.Value2)
Next myCell
End Sub
Then, refer the Worksheet_Change event to it. As far as the Worksheet_Change event is quite "expensive", running always, it is a good idea to run it only when a specific Target cell is changed and otherwise exit the procedure - If Intersect(Target, Range("C6"), Range("C9:G9")) Is Nothing Then Exit Sub
The Application.EnableEvents = False is needed to disable the events. At the end it is set back to True.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C6"), Range("C9:G9")) Is Nothing Then Exit Sub
Application.EnableEvents = False
FixRangeLCase Range("C6")
FixRangeLCase Range("C9:G9")
Application.EnableEvents = True
End Sub
Also you can use:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
Application.EnableEvents = False
If Not Intersect(Target, Range("C6")) Is Nothing Or Not Intersect(Target, Range("C9:G9")) Is Nothing Then
Set rng = Range("C9:G9", "C6")
For Each cell In rng
cell.Value = LCase(cell.Value)
Next
End If
Application.EnableEvents = True
End Sub
I have 2 private sub worksheet_change subs that need to be on the same sheet and can't work out how to combine them. Very new to this whole vba game and both subs I have found on various websites. Any help would be greatly appreciated. The 2 pieces of code are below. One gets the time a cell changes and the other dispalys a message box when another cell changes (Have updated since first post. Both are worksheet_change subs
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rCell As Range
Dim rChange As Range
On Error GoTo ErrHandler
Set rChange = Intersect(Target, Range("A:A"))
If Not rChange Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChange
If rCell > "" Then
With rCell.Offset(0, 1)
.Value = Now
.NumberFormat = "hh:mm:ss"
End With
Else
rCell.Offset(0, 1).Clear
End If
Next
End If
ExitHandler:
Set rCell = Nothing
Set rChange = Nothing
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
And second one is
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Application.Intersect(Range("AH4"), Target) Is Nothing) Then
MsgBox "Broadcast Now!"
End If
End Sub
I have a macro where i import a text file and update some elements of this file using the macro and then re-create the text file with the updated elements. I am validating some of the cells in a particular worksheet (USERSHEET)to make sure the user entries are correct and using the below Sub:
Option Explicit
Public Rec_Cnt As Integer
Private Sub Worksheet_Change(ByVal Target As Range)
Rec_Cnt = Sheets("MD").Cells(3, 7)
Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Set Rng1 = Range("E2:E" & Rec_Cnt)
Set Rng2 = Range("K2:K" & Rec_Cnt)
Set Rng3 = Range("Q2:Q" & Rec_Cnt)
If Not Application.Intersect(Target, Rng1) Is Nothing Then
If Len(Target) > 10 Then
Call Original_Ticket_Error
Exit Sub
End If
ElseIf Not Application.Intersect(Target, Rng2) Is Nothing Then
If Len(Target) > 10 Then
Call Original_Cnj_Ticket_Error
Exit Sub
End If
ElseIf Not Application.Intersect(Target, Rng3) Is Nothing Then
If Len(Target) > 10 Then
Call Original_Ticket_Error
Exit Sub
End If
End If
End Sub
Sub Original_Ticket_Error()
MsgBox "Original Ticket Number is more 10 characters"
End Sub
Sub Original_Cnj_Ticket_Error()
MsgBox "Original Conj. Ticket Number is more 10 characters"
End Sub
===============================================================================
Once the text file is created with the updated columns I am clearing all the cells in the USERSHEET.
However, I get a run-time error '13' for type mismatch
I wanted to check how can I avoid calling the Private Sub Worksheet_Change(ByVal Target As Range) after the worksheet(USERSHEET) is cleared
Any help is much appreciated.
Thanks,
sachin
Edit:
Code used to clear usersheet:
Sub Clear_User_Sheet()
Sheets("UserSheet").Select
Range("A2:R100002").Select
Application.Wait (Now + TimeValue("0:00:01"))
Selection.Delete
Application.EnableEvents = False
Application.Wait (Now + TimeValue("0:00:01"))
Selection.Delete
Selection.Delete
Sheets("Control Panel").Select
End Sub
Try this version of Clear_User_Sheet instead:
Sub Clear_User_Sheet()
Application.EnableEvents = False
Sheets("UserSheet").Range("A2:R100002").Delete
Application.EnableEvents = True
End Sub
PS. If you've used the code that you suggested in your edited answer, you may well find that EnableEvents is currently set to False - you'll want to correct that before running anything else.