Below code that was in use for a while isn't working anymore.
I did a test in new sheet without other code with the same result.
We've recently moved to Office 365 and my current Excel version is 1902.
Unfortunately everyone here has the same version now, so I can't test it on an older one.
I mention this because I can't think of anything but this being due to a new bug?
Edit: I should add that this was used to prevent (re)moving rows or columns.
Edit: What doesn't work: It triggers twice every time. (I left this important part out after several edits)
Private Sub Workbook_SheetChange(ByVal wks As Object, ByVal Target As Range)
If ((Target.Address = Target.EntireRow.Address Or _
Target.Address = Target.EntireColumn.Address)) Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
MsgBox "Do not modify the structure.", vbExclamation, "Notice"
End With
End If
End Sub
you could try and turn it into a SelectionChange event
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If ((Target.Address = Target.EntireRow.Address Or _
Target.Address = Target.EntireColumn.Address)) Then
With Application
.EnableEvents = False
Target.Cells(1, 1).Select
.EnableEvents = True
End With
MsgBox "Do not modify the structure.", vbExclamation, "Notice"
End If
End Sub
that would preserve you from Undo usage and all its consequences
Related
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Range("B12").Address Then
Application.EnableEvents = False
Dim sOldValue As String, sNewValue As String
sNewValue = Target.Value
Application.Undo
Dim rOld As Range
Set rOld = Range("A1:E1").Value
Target.Value = sNewValue
Range("A15:E15").Value = rOld.Value
Application.EnableEvents = True
End If
End Sub
How to run this function, can you please call this function?
Create a button, add in the following code, you might need to change your code from Private to Public
`Private Sub CommandButton1_Click()
Call Worksheet_Change
End Sub`
The code you posted is for the Worksheet.Change event. The event occurs when cells on the worksheet are changed by the user or by an external link.
All you need to run this sub is to place the code in the sheet module for the relevant sheet and change B12 cell.
A Worksheet Change: Change Range Values on Cell Change
Worksheet_ in the signature Private Sub Worksheet_Change(ByVal Target As Range) indicates that this procedure belongs in the sheet module, e.g. Sheet1, of the worksheet where you want it applied (not in the ThisWorkbook module nor in a standard module, e.g. Module1). Such a procedure will run automatically (get triggered) when an event occurs, particularly for this procedure, after a manual change has happened in a range i.e. after
you write something into the formula bar and press enter,
you (copy) paste values to a range, or
you use VBA to write values to a range.
In this procedure, if you want to write something to a range of the worksheet, to not retrigger the event and possibly end up with an endless loop ('crashing' Excel), you will disable events before you start writing, and enable them after writing as you did in your code. If an error occurs between these two lines, the events will stay disabled and the code won't trigger until they are enabled again.
To check if events are enabled you could use the line Debug.Print Application.EnableEvents in another procedure or in the Immediate window just use ?Application.EnableEvents and press enter. Similarly, if the answer is False, in the Immediate window, you can use Application.EnableEvents = True and press enter to enable events.
The line Set rOld = Range("A1:E1").Value is wrong and results in
Run-time error '424': Object required
To avoid the error you could use one of the following:
Dim rgOld As Range: Set rgOld = Range("A1:E1")
Range("A15:E15").Value = rgOld.Value
Target.Value = sNewValue
Dim OldValues() As Variant: OldValues = Range("A1:E1").Value
Range("A15:E15").Value = OldValues ' or after the following line
Target.Value = sNewValue
Range("A15:E15").Value = Range("A1:E1").Value
Target.Value = sNewValue
Basically, you want to write the data before rewriting the new value. Optionally, in the second case where the data is written to an array (OldValues), you can write the values afterward.
Since the use of an additional variable is kind of redundant in the first two cases, the last (the simplest, the most straightforward) case is used in the following code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$12" Then Exit Sub
Dim NewString As String: NewString = CStr(Target.Value)
Application.EnableEvents = False
Application.Undo ' this will also write (trigger the event)
Me.Range("A15:E15").Value = Me.Range("A1:E1").Value
Target.Value = NewString ' redo
Application.EnableEvents = True
End Sub
If you want to modify (experiment with) the code, you should introduce some error handling so you don't end up with events disabled.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
If Target.Address <> "$B$12" Then Exit Sub
Dim NewString As String: NewString = CStr(Target.Value)
Application.EnableEvents = False
Application.Undo ' this will also write (trigger the event)
Me.Range("A15:E15").Value = Me.Range("A1:E1").Value
Target.Value = NewString ' redo
SafeExit:
On Error Resume Next
If Not Application.EnableEvents Then Application.EnableEvents = True
On Error GoTo 0
Exit Sub
ClearError:
Debug.Print "Run-time error'" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
One thing is basic: how did you create this function? Did you open the Excel VBA editor, select a sheet and chose the corresponding event, like I did in the following screenshot:
As you see, the macro is linked to "Sheet1", it is linked to the events of the "Worksheet" itself, and it is triggered by any "Change" of that worksheet.
I have seen where you can run a macro based on inserted text, but the macro has to be embedded in the sheet, i.e., Private Sub Worksheet_Change(ByVal Target As Range).
What I want to do is call the macro from my add-in from a user's workbook that will not have "Worksheet_Change..." already embedded at the sheet level. Is there a way to do this?
As for additional background, I know I can run the macro from the add in, but I want to activate it using a bar-code scan rather than calling the macro from a button or some other interface.
My bar-code reads as Make Landscape 1 pg when scanned. Hoping to use some modification of this:
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Value) = "Make Landscape 1 pg" Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Application.ScreenUpdating = False
'ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.Select
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.ScreenUpdating = True
End If
End Sub
Here's a link that I found very useful when needing to access Worksheet/Workbook-level events via modules in my Add-In. The basic implementation is like so:
In Add-In's ThisWorkbook module:
Private WithEvents App As Application
Private Sub Workbook_Open()
Set App = Application
End Sub
Now App can be used to call/access workbook & worksheet events. If you're trying to check something upon selection change from a module in an add-in it has to be Workbook_Sheetselectionchange event (which you can read more about here) instead of the Worksheet_Change event. This event can be used in conjunction with the previously set App variable like so:
In Add-In's ThisWorkbook module:
Private Sub App_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Excel.Range)
If (Target.Value) = "Make Landscape 1 pg" Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Application.ScreenUpdating = False
ActiveSheet.Select
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.ScreenUpdating = True
End If
End Sub
I have a problem in Excel 2013. Yesterday I put the following code in Excel by rightclicking the tab of my worksheet (Alt-F11) :
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("D3:T42")) Is Nothing Then
Application.EnableEvents = False
If Target.Value = ChrW(&H2713) Then
Target.ClearContents
Cancel = True
Else
Target.Value = ChrW(&H2713)
Cancel = True
End If
End If
Application.EnableEvents = True
End Sub
This code is supposed to add a checkmark in the defined cells after double clicking. While this code worked fine yesterday, it now does not work anymore. I have tried everything but just do not get it to work. Any ideas ?
PS I would like to use such a code since a sheet with many form checkboxes makes it very slow (at least in my case)
Regards, Arno
Some error in one test may have made EnableEvents keep false eternally.
Run a single sub with Application.EnableEvents = true and test it again.
If that is false, no event will be thrown at all, no clicks, no double clicks, nothing will work.
I suggest you add an On error goto statement, to avoid that kind of problem:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error goto 1
If Not Intersect(Target, Range("D3:T42")) Is Nothing Then
Application.EnableEvents = False
If Target.Value = ChrW(&H2713) Then
Target.ClearContents
Cancel = True
Else
Target.Value = ChrW(&H2713)
Cancel = True
End If
End If
on error goto 0
1 Application.EnableEvents = True
End Sub
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Does the validation range still have validation?
If Not HasValidation(Range("A1:A1048576")) Then RestoreValidation
If Not HasValidation(Range("C1:C1048576")) Then RestoreValidation
If Not HasValidation(Range("I1:I1048576")) Then RestoreValidation
If Not HasValidation(Range("P1:P1048576")) Then RestoreValidation
End Sub
Private Sub RestoreValidation()
Application.EnableEvents = False
'turn off events so this routine is not continuously fired
Application.Undo
Application.EnableEvents = True
'and turn them on again so we can catch the change next time
MsgBox "Your last operation was canceled." & _
"It would have deleted data validation rules.", vbCritical
End Sub
Private Function HasValidation(r) As Boolean
' Returns True if every cell in Range r uses Data Validation
On Error Resume Next
Debug.Print r.Validation.Type 'don't care about result, just possible error
If Err.Number = 0 Then HasValidation = True Else HasValidation = False
End Function
I applied validation on 4 columns with the above code, Even the validation is passed I am getting 4 error pop up messages how to restrict number of error messages ?
UPDATE:
I selected the value from the drop down which is a valid selection, but I am getting the below error message.
I am using the following code
If you are working with the sheet's Change event, then I would recommend having a look at THIS
Since you are working with just one sheet then you don't need the code in the ThisWorkbook code area. If you put it there then the code will run for every sheet. Put the code in the relevant sheet's code area. So if the validation is in Sheet1 then put the code in the Sheet1 code area. See ScreenShot below.
Ok now to address your query. What you can do is use a Boolean variable and then set it to True after you show the first message so that the message doesn't show again.
Try this (UNTESTED)
Dim boolDontShowAgain As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
If Not HasValidation(Range("A1:A1048576")) Then RestoreValidation
If Not HasValidation(Range("C1:C1048576")) Then RestoreValidation
If Not HasValidation(Range("I1:I1048576")) Then RestoreValidation
If Not HasValidation(Range("P1:P1048576")) Then RestoreValidation
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Private Sub RestoreValidation()
Application.Undo
If boolDontShowAgain = False Then
MsgBox "Your last operation was canceled." & _
"It would have deleted data validation rules.", vbCritical
boolDontShowAgain = True
End If
End Sub
Private Function HasValidation(r) As Boolean
On Error Resume Next
Debug.Print r.Validation.Type
If Err.Number = 0 Then HasValidation = True
End Function
Apologies if this has been answered before, but event handling is still quite new to me.
What I'm trying achieve is to double-click on a cell to cut it to the clipboard, and then when I click on a new cell for the cut cell to be inserted at that point, shifting the existing cells down.
The double-click bit to cut the cell is easy enough:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Target.Cut
End Sub
... but the rest of it is not obvious to me given that it needs to call another event (SelectionChange I'm assuming) from within an event.
How is this achieved? I've done some searching -- and I'm sure it's going to be obvious -- but I'm probably not searching on the right terms.
Thanks in advance.
EDIT: Many thanks for the answer.
As the ever-popular follow-up question -- is there a way to accomplish the same thing when dragging a cell using the grab-the-border method: i.e. have the cell dragged and inserted rather than invoke the "do you want to replace" dialogue? I know this can be done by holding down the Shift key -- but I'm looking for a way to code a sheet so that a drag-and-dropped cell will insert automatically rather than overwrite.
How about this?
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Target.Cut
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = xlCut Then
Target.Insert Shift:=xlDown
Application.CutCopyMode = False
End If
End Sub
Update:
There isn't a drag event for cells but a hacky workaround based on this link http://www.mrexcel.com/forum/excel-questions/284788-challenging-post-override-cell-drag-drop-behavior-2.html
This essentially allows the drag, then applies UNDO to find the target and destination cells. The only addition I've made is to add Application.AlertBeforeOverwriting to disable the overwrite message.
Dim trigger As Boolean
Dim flag As Boolean
Dim busy As Boolean
Const overwriteAlert As Boolean = False
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Count = 1 And trigger Then
If flag Then
If busy Then Exit Sub
busy = True
Call MyDrag
flag = False
Else
flag = True
End If
End If
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
flag = False
busy = False
trigger = Target.Count = 1
Application.AlertBeforeOverwriting = overwriteAlert
End Sub
Sub MyDrag()
Dim DragAddress As String
Dim DropAddress As String
With Application
.EnableEvents = False
.ScreenUpdating = False
DropAddress = ActiveCell.Address
.Undo
DragAddress = ActiveCell.Address
If Range(DropAddress).Column = Range(DragAddress).Column Then
.Undo
Else
With Range(DropAddress)
.Activate
.Insert Shift:=xlDown
.Offset(-1) = Range(DragAddress)
End With
Range(DragAddress).Delete Shift:=xlUp
End If
.ScreenUpdating = True
.EnableEvents = True
End With
'busy = False
End Sub