I have a VBA code to capitalize most of my worksheet but when I delete or clear the contents I get the debug message.
Any help would be appreciated!
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("A:Z")) Is Nothing Then
Target.Value = UCase(Application.Substitute(Target.Value, " ", ""))
End If
Application.EnableEvents = True
End Sub
If you delete/change/add more than a single cell then Target is more than one cell and you cannot make the value uppercase as you are doing. Loop through the intersection of Target and columns A:Z and make each uppercase.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("A:Z")) Is Nothing Then
dim rng as range
for each rng in Intersect(Target, Range("A:Z"))
rng.Value = UCase(Replace(rng.Value, chr(32), vbnullstring))
next rng
End If
Application.EnableEvents = True
End Sub
Related
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
I have a spreadsheet that has data validation in cells A2-A999 with the only option in the drop down menu being "Today" (without the quotation marks). I have a VBA code that changes the cell's value to today's date when "Today" is selected in the cell. However, this code has a problem. When I clear the contents of a group of cells, including the cell that has today's date in it, the spreadsheet thinks, then debugs and then closes; for example clearing A1 & B1 simultaneously.
However, if I clear A1 by itself, it clears the cell with no problems.
P.S. By " I clear", I meant to say: "I select the group of cells with the mouse and then hit the backspace button."
Can you guys help me fix the code so that I can clear many cells at the same time, including the cell with data validation.
The code that I am using is pasted in the worksheet section and is as the following:
Private Sub Worksheet_Change(ByVal Target As Range)
selectedVal = Target.Value
If Target.Column = 1 Then
selectedNum = Application.VLookup(selectedVal, Worksheets("DATA-
O").Range("DateToday"), 2, False)
If Not IsError(selectedNum) Then
Target.Value = selectedNum
End If
End If
End Sub
The answer to your problem is (as Dirk Reichel just mentioned in a comment) to loop through each of the affected cells:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Columns(1), Target) Is Nothing Then
For Each c In Intersect(Columns(1), Target).Cells
selectedVal = c.Value
selectedNum = Application.VLookup(selectedVal, Worksheets("DATA-O").Range("DateToday"), 2, False)
If Not IsError(selectedNum) Then
Application.EnableEvents = False 'As recommended by K Paul
c.Value = selectedNum
Application.EnableEvents = True
End If
Next
End If
End Sub
However, based on what you say that the code is doing, I'm not sure why you don't just use:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Columns(1), Target) Is Nothing Then
For Each c In Intersect(Columns(1), Target).Cells
If c.Value = "Today" Then
Application.EnableEvents = False 'As recommended by K Paul
c.Value = Date
Application.EnableEvents = True
End If
Next
End If
End Sub
If you want to be fast, there are 2 ways.
Use Evaluate to do it array-like:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Columns(1), Target) Is Nothing Then
With Intersect(Columns(1), Target)
If Evaluate("AND(" & .Address & "<>""Today"")") Then Exit Sub
.Value = Evaluate("IF(" & .Address & "=""Today"",TODAY()," & .Address & ")")
End With
End If
End Sub
or use Range.Replace which also can be very fast:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Columns(1), Target) Is Nothing Then
Intersect(Columns(1), Target).Replace "Today", Date, xlWhole, , True, , False, False
End If
End Sub
A small hint: hitting ctrl & ; will directly input todays date
I used to have the following code and it used to work but for some reason it no longer works.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim test As Range
Dim KeyCells As Range
Dim i As String
Set KeyCells = Range("AF3:AF5000")
test = Target.Rows.Count
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
For i = Target.Row To (Target.Row + (Target.Rows.Count - 1))
If Not ActiveSheet.Cells(i, 32) = "" Then
ActiveSheet.Cells(i, 20).Value = "Closed"
End If
Next
End If
End sub
Basically if there is data in any cells of column AF then the cell align with the information in column T would mark Closed. For example if AF65 <>"" then T65.value ="Closed"
Any idea why it no longer works or if there is another possibility for a macro?
Get rid of the redundant code and non-specific worksheet references. For example, a Worksheet_Change can be triggered when that worksheet is not the Activesheet; putting in Activesheet when it is not required only confuses the issue.
You also are not disabling events so your sub is going to try to run on top of itself.
This should be closer to what you are attempting to perform.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("AF3:AF5000"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim trgt As Range
For Each trgt In Intersect(Target, Range("AF3:AF5000"), Target.Parent.UsedRange)
If CBool(Len(trgt.Value2)) Then
trgt.Offset(0, -12) = "Closed"
Else
trgt.Offset(0, -12) = vbNullString
End If
Next trgt
End If
safe_exit:
Application.EnableEvents = True
End Sub
If your original sub just 'stopped working' then put Application.EnableEvents = True into the VBE's Immediate window and tap [enter]. It is possible that your earlier code crashed with event handling disabled.
I'm setting a Worksheet_Change Macro so that if the contents of Cell K4 are not equal to "Event Based" the contents of J5:K7 are cleared. This works great. Code below.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MRange As Range
Set MRange = Range("K4")
If MRange <> "Event Based" Then
If Union(Target, MRange).Address = MRange.Address Then
Application.EnableEvents = False
Range("J5:K7").Select
Selection.ClearContents
Application.EnableEvents = True
End If
End If
End Sub
But I want a Worksheet_Change event if contents of cell J12 are cleared. But the below macro does NOT work. I know it is to do with cell value being empty, but I would appreciate any help.
Dim NRange As Range
Set NRange = Range("J12")
If NRange = "" Then
If Union(Target, NRange).Address = NRange.Address Then
Application.EnableEvents = False
Range("J5:K7").Select
Selection.ClearContents
Application.EnableEvents = True
End If
End If
End Sub
The code below checks if Cell J12 value has changed, if cell's value is "" then it clears the content of Range "J5:K7".
Private Sub Worksheet_Change(ByVal Target As Range)
Dim IntersectRange As Range
Dim NRange As Range
Set NRange = Range("J12")
Set IntersectRange = Intersect(Target, NRange)
' continue running this code only if Cell J12 has changed
If Not IntersectRange Is Nothing Then
If Target.Value = "" Then
Application.EnableEvents = False
Range("J5:K7").ClearContents
Application.EnableEvents = True
End If
End If
End Sub
The code that is running on my excel spreadsheet that I am working on is working fine, expect for when I copy and import information into the protected cells it gives me a type mismatch error and can not figure out how to fix the code.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
If Len(Trim(Target.Value)) = 0 Then Application.Undo
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
When you paste a number of values into two or more cells within the C1:C20 range, the Target is more than 1 and you cannot use the Range.Value property of Target.
Typically, you would use something like the following.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
'do not do anything until you know you are going to need it
On Error GoTo Whoa
Application.EnableEvents = False
Dim crng As Range
'in the event of a paste, Target may be multiple cells
'deal with each changed cell individually
For Each crng In Intersect(Target, Range("C1:C20"))
If Len(Trim(crng.Value)) = 0 Then Application.Undo
'the above undoes all of the changes; not just the indivual cell with a zero
Next crng
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
However, your desire to use Application.Undo presents some unique problems because you do not want to undo all of the changes; just the ones that result in zero. Here is a possible solution.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
'do not do anything until you know you are going to need it
On Error GoTo Whoa
Application.EnableEvents = False
Dim c As Long, crng As Range, vals As Variant, prevals As Variant
'store the current values
vals = Range("C1:C20").Value2
'get the pre-change values back
Application.Undo
prevals = Range("C1:C20").Value2
'in the event of a paste, Target may be multiple cells
'deal with each changed cell individually
For c = LBound(vals, 1) To UBound(vals, 1)
If vals(c, 1) = 0 Then vals(c, 1) = prevals(c, 1)
Next c
Range("C1:C20") = vals
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
The new values are stored in a variant array and then the paste is undone. The old values are stored in another variant array. The new values are walked through and if a zero comes up, it is replaced with the old value. Finally, the revised set of new values is pasted back into the C1:C20 range.
Your sheet must be protected, so you need to unprotect your sheet first:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Sheets("NameOfYourSheet").Unprotect Password:="YourPassWord" ' Change the name of the sheet which is locked
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
If Len(Trim(Target.Value)) = 0 Then Application.Undo
End If
Sheets("NameOfYourSheet").Protect Password:="YourPassWord"
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub