I am trying to have a column automatically format when a fraction is input. Excel by default had been converting the fraction 5/2 to 2.50, which is fine in certain circumstances, but I actually needed it to input what is the Starting Price of a selection, which means if 5/2 is input, the actual calculation would be =5/1+1 (3.50), so it adds in the original stake of 1 as well. 15/8 would be =15/8+1 (2.88) and so on.
In the worksheet, I have the following VBA code.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo err_handler
Application.EnableEvents = False
If Target = Empty Then GoTo exit_handler
If Not Intersect(Target, Columns("Q")) Is Nothing Then
With Target
.Formula = Evaluate(.Formula & "+1")
End With
End If
exit_handler:
Application.EnableEvents = True
Exit Sub
err_handler:
MsgBox Err.Number & ": " & Err.Description
Resume exit_handler
End Sub
OK, resolved thanks so much. This seems to work perfectly
I am not sure you understood how exactly to use the function, even if I could be wrong... In order to work as you wish, you must proceed in the next way:
Create a Worksheet_Change event for the sheet where you intend to work. It will only call your above function.
Private Sub Worksheet_Change(ByVal Target As Range)
Starting_Price Target
End Sub
If you do not know how to create such an event, do not hesitate to ask;
Then you must put your above code in the same sheet module. Exactly as it is or slightly modified to use only VBA (without RegExp):
Private Sub Starting_Price(ByVal Target As Range)
On Error GoTo err_handler
Application.EnableEvents = False
If Target = Empty Then GoTo exit_handler
If Not Intersect(Target, Columns("P")) Is Nothing Then
With Target
If Target.HasFormula Then
.Formula = .Formula & "+1"
End If
End With
End If
exit_handler:
Application.EnableEvents = True
Exit Sub
err_handler:
MsgBox Err.Number & ": " & Err.Description
Resume exit_handler
End Sub
Take care to input (only in column P:P) your fraction like formula:
= 5/2;
Be sure that your Excel workbook is a .xlsm type.
Sorry, may have posted the answer above where the original code was.
This code seemed to solve the problem, so thanks very much for the input
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo err_handler
Application.EnableEvents = False
If Target = Empty Then GoTo exit_handler
If Not Intersect(Target, Columns("Q")) Is Nothing Then
With Target
.Formula = Evaluate(.Formula & "+1")
End With
End If
exit_handler:
Application.EnableEvents = True
Exit Sub
err_handler:
MsgBox Err.Number & ": " & Err.Description
Resume exit_handler
End Sub
Related
I create a new module and insert this code:
Sub test()
Set wsData = ThisWorkbook.Worksheets("Data")
sCount = wsData.Columns(14).SpecialCells(xlCellTypeBlanks).Count
msgbox sCount
End Sub
In the worksheet "Data", I have this code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.CountLarge = 1 Then
If Not Intersect(Target, Range("K:M")) Is Nothing And Target.Value <> "" Then
'code
End if
End if
End Sub
When I run the test() sub, I get a type mismatch error on If Not Intersect(Target, Range("K:M")) Is Nothing, as Target wrong type.
Why this is happening?
Why is test triggering the Change Event?
I dont get the same error if manually filter column 14 of my Data sheet to leave only the blank cells!
The problem with the type mismatch, is that the Target.Cells is more than one cell. Thus, the Target.Value <> "" throws type mismatch, because multiple cells cannot be compared to "". See the MsgbBox with the number of cells:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.CountLarge = 1 Then
If Target.Cells.CountLarge > 1 Then MsgBox Target.Cells.CountLarge
If Not Intersect(Target, Range("K:M")) Is Nothing And Target.Value <> "" Then
'code
End If
End If
End Sub
Based on the business logic there could be several solutions.
The easiest one is to write
If Target.Cells.CountLarge > 1 Then Exit Sub in the _SelectionChange event.
Another way is to disable events around
sCount = wsData.Columns(14).SpecialCells(xlCellTypeBlanks).Count like this:
Sub TestMe()
Set wsData = ThisWorkbook.Worksheets("Data")
Application.EnableEvents = False
sCount = wsData.Columns(14).SpecialCells(xlCellTypeBlanks).Count
Application.EnableEvents = True
msgbox sCount
End Sub
I almost closed this question as a duplicate.
I will answer both your questions but in the reverse order so that you can understand it better.
Why is test triggering the Change Event?
I have explained it in SpecialCells causing SheetSelectionChange event in Excel 2010
When I run the test() sub, I get a type mismatch error on If Not Intersect(Target, Range("K:M")) Is Nothing, as Target wrong type.
Why this is happening?
When the procedure Test triggers the Worksheet_SelectionChange event, your code will fail on the line
If Not Intersect(Target, Range("K:M")) Is Nothing And Target.Value <> "" Then
It is because Target.Value <> "" is the culprit as SpecialCells(xlCellTypeBlanks).Count may return multiple cells.
If you break the above line in 2 lines then you will not get an error
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("K:M")) Is Nothing Then
If Target.Value <> "" Then
'code
End If
End If
End Sub
Is it possible to make the msgbox of this code to appear only once? My problem is that if the user inserts data i.e. from row 501 until 510 the message box will appear 9 times, and I want to have it only once. The reason of this is because the code looks in each cell to verify if something is inserted, and then the content is deleted and the msg appears. If it is possible I would like to keep the format of the code below, but only to show the msgbox once. If not, any suggestions would be welcomed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell22 As Range
Application.EnableEvents = False
For Each cell22 In Target
If Not Application.Intersect(cell22, Range("a501:z6000")) Is Nothing Then
If cell22.Value <> "" Then
cell22.ClearContents
MsgBox "You cannot insert more than 500 rows", vbInformation, "Important:"
End If
End If
Next cell22
Application.EnableEvents = True
End Sub
I would suggest another way.
The tasks which access the worksheet, such as ClearContents takes the longer to process.
So instead of clearing the contents each time inside the loop for a single cell, and repeat it a few hundred times, use ClrRng as a Range object. Every time the If criteria is met, you add it to ClrRng using the Application.Union function.
Once you finish looping through all your cells, clear the entire cells in ClrRng at the same time.
Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell22 As Range, b As Boolean
Dim ClrRng As Range ' define a range to add all cells that will be cleared
Application.EnableEvents = False
For Each cell22 In Target
If Not Application.Intersect(cell22, Range("A501:Z6000")) Is Nothing Then
If cell22.Value <> "" Then
If Not ClrRng Is Nothing Then
Set ClrRng = Application.Union(ClrRng, cell22)
Else
Set ClrRng = cell22
End If
End If
End If
Next cell22
If Not ClrRng Is Nothing Then ' make sure there is at least 1 cell that passed the If criteria
ClrRng.ClearContents ' clear all cell's contents at once
MsgBox "You cannot insert more than 500 rows", vbInformation, "Important:"
End If
Application.EnableEvents = True
End Sub
Try this:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell22 As Range
Application.EnableEvents = False
For Each cell22 In Target
If Not Application.Intersect(cell22, Range("a501:z6000")) Is Nothing Then
If cell22.Value <> "" Then
cell22.ClearContents
GoTo displayMsg
End If
End If
Next cell22
Application.EnableEvents = True
Exit Sub
displayMsg:
MsgBox "You cannot insert more than 500 rows", vbInformation, "Important:"
Application.EnableEvents = True
End Sub
This will only show it once but clear each cell which is non-blank.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell22 As Range, b As Boolean
Application.EnableEvents = False
For Each cell22 In Target
If Not Application.Intersect(cell22, Range("a501:z6000")) Is Nothing Then
If cell22.Value <> "" Then
cell22.ClearContents
b = True
End If
End If
Next cell22
If b Then MsgBox "You cannot insert more than 500 rows", vbInformation, "Important:"
Application.EnableEvents = True
End Sub
I have the following code which on selection change of a cell searches a separate sheet:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub
Dim Finder, ClickRange
Set ClickRange = ThisWorkbook.Sheets("Sheet3").Range("A:A")
If Intersect(Target, ClickRange) Is Nothing Then Exit Sub
Set Finder = ThisWorkbook.Sheets("Sheet4").Range("A:A").Find(Target.Value, LookAt:=xlWhole)
If Finder Is Nothing Then Exit Sub
MsgBox (Finder.Row)
End Sub
However the code isn't working even though in ThisWorkbook I have the following code enabling events
Private Sub Workbook_Open()
Application.EnableEvents = True
End Sub
My sheet names are as follows
Any idea what I might be doing wrong?
Open Immediate Window and type ?Application.EnableEvents
What do you get? A True or False?
If you get True, all is well but if you get False that means Events are disabled somehow (not because of the selection change event code but maybe because of some other code in the workbook).
To enable it again, Type Application.EnableEvents=True in the Immediate Window.
Now place the following code on Sheet3 Module and see if that works fine for you.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
Dim sws As Worksheet
Dim Finder As Range
Set sws = Sheets("Sheet4")
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target <> "" Then
Set Finder = sws.Range("A:A").Find(Target.Value, lookat:=xlWhole)
If Not Finder Is Nothing Then
MsgBox Finder.Row
Else
MsgBox Target.Value & " was not found on " & sws.Name & ".", vbExclamation, "Not Found!"
End If
End If
End If
End Sub
Try enabling and disabling events like below. This will not only ensure that Events are enabled but will avoid potential issue of calling the event in a loop.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Goto errExit
Application.EnableEvents = False
If Target.CountLarge > 1 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub
Dim Finder As Range ', ClickRange
'Set ClickRange = ThisWorkbook.Sheets("Sheet3").Range("A:A")
'/* If this code is in Sheet3, you can use below */
If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
Set Finder = _
ThisWorkbook.Sheets("Sheet4").Range("A:A").Find(Target.Value, _
LookAt:=xlWhole)
If Finder Is Nothing Then Exit Sub
MsgBox (Finder.Row)
errExit:
Application.EnableEvents = True
End Sub
Try this first and let us know what you get. Hope this helps.
I am stuck up with one of the VBA code. My requirement is when the user selects the option "Resigned" in K row from the data validation provided he should get a pop up messages as "Please provide the user's Last Working Date in DD-MM-YYYY format on column L2". Here L2 is just an example.
But, when I hit the delete key by selecting the range K2:K18 getting an message "Runtime error 13, type mismatch"
Please help to resolve this :(
Following is my code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("K:K")) Is Nothing Then Exit Sub
If Target.Value <> "Resigned" Then Exit Sub
MsgBox "Please provide the user's Last Working Date in DD-MM-YYYY format on " & Target.Offset(0, 1).Address
End Sub
You need to check If Target.Cells.Count <> 1 and handle appropriately.
In your case, you're causing the _Change event to take the Target argument as Range("K2:K18") which is an array, hence the type mismatch error.
Here is a simple case which just aborts the procedure if Target is more than 1 cell range:
Private Sub Worksheet_Change(ByVal Target As Range)
'Conditions which cause the event to terminate early, avoid errors
If Target.Cells.Count <> 1 Then Exit Sub
If Intersect(Target, Range("K:K")) Is Nothing Then Exit Sub
If Target.Value = "Resigned" Then
MsgBox "Please provide the user's Last Working Date in DD-MM-YYYY format on " & Target.Offset(0, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Application.GoTo Target.Offset(0,1)
End If
End Sub
Or, to handle multiple cell range, you could do something like:
Private Sub Worksheet_Change(ByVal Target As Range)
'Conditions which cause the event to terminate early, avoid errors
Dim rng As Range, cl As Range, msg as String
Set rng = Intersect(Target, Range("K:K"))
If rng Is Nothing Then Exit Sub
For Each cl in rng
If cl.Value = "Resigned" Then
msg = msg & vbCRLF & cl.Offset(0,1).Address(False,False)
End If
Next
If msg <> vbNullString Then
MsgBox "Please provide the user's Last Working Date in DD-MM-YYYY format on " & vbCrlf & msg
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