I have to change several defaults which my macro fixes at the end, but if I need to interrupt the macro, the settings will not be reset.
So if the code contains
Application.Calculation = xlCalculationManual
then I would have
Private Sub IfInterrupted()
Application.Calculation = xlCalculationAutomatic
End Sub
Is there any way to do this?
If you really really need to do this, then this is how:
Sub YourSub()
On Error GoTo ErrHandler:
Application.EnableCancelKey = xlErrorHandler
' You code goes here
ErrHandler:
With Err
If .Number <> 18 Then
.Raise .Number, .Source, .Description, .HelpFile, .HelpContext
End If
End With
Application.Calculation = xlCalculationAutomatic
End Sub
However, there are better ways to achieve whatever it is you are trying to achieve. For example, polling for user input.
Related
Using the following code to auto upper two columns,
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Application.Intersect(Target, Range("C2:C5000", "P3:P5000")) _
Is Nothing) Then
With Target
Application.EnableEvents = False
.Value = UCase(.Value)
Application.EnableEvents = True
End With
End If
End Sub
Works perfectly, the problem is, if a user selects multiple cells, and hits delete, it errors, then the user hits End and the function no longer works. protected. Run-time error 13, type mismatch.
Doesn't matter if the cell is empty or not, still get the error.
Thanks in advance.
The answer of #ScottHoltzman solves the issue of the current problem, where an error is raised when you apply UCASE to an Array. When the Target range has more than one cell its .Value is an array, and UCase does not accept an array parameter.
Your routine will exit this line (.Value = UCase(.Value)) and will miss the next line that resets Application.EnableEvents = True. After that, you end up working with events disabled, so all your event handling routines will stop working, not only this one (in case you had other such routines).
To avoid these situations the good approach is to implement proper error handling in event handlers, following this structure
Sub my_Handler()
On Error Goto Cleanup
Application.EnableEvents = False: Application.ScreenUpdating = False ' etc..
''''''''''''''''''''''''''''''''''
'
' normal code of the routine here
'
''''''''''''''''''''''''''''''''''
Cleanup:
if Err.Number <> 0 Then MsgBox Err.Description
Application.EnableEvents = True, Application.ScreenUpdating = True ' etc..
End Sub
To apply it to your routine:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Cleanup
Application.EnableEvents = False: Application.ScreenUpdating = False ' etc..
If Not (Application.Intersect(Target, Range("C2:P5000")) Is Nothing) Then
Target.value = UCase(Target.value)
End If
Cleanup:
If Err.Number <> 0 Then msgBox Err.Description
Application.EnableEvents = True: Application.ScreenUpdating = True ' etc..
End Sub
Importantly, don't use this structure automatically for all you routines, only Event handlers or eventually macros ythat you would invoke from the GUI. Other routines are usually called from these handlers or macros, so you can write them normally.
I tried putting this in a comment to the answer, but was too long, so sorry..
#a-s-h #a.s.h
This one worked the best, with a slight modification. Thanks!
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Cleanup
Application.EnableEvents = False: Application.ScreenUpdating = False ' etc..
If Not (Application.Intersect(Target, Range("C2:C5000", "P3:P5000")) Is Nothing) Then
Target.Value = UCase(Target.Value)
End If
Cleanup:
If Err.Number <> 0 Then GoTo EndLine
EndLine:
Application.EnableEvents = True: Application.ScreenUpdating = True ' etc..
End Sub
Performs uppercase, and deletes multiples at once without any errors, or MsgBox's.
If they are selecting multiple cells then my thinking is that you would want to use SelectionChange macro instead, like this
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
If ((Target.Address = Target.EntireRow.Address Or _
Target.Address = Target.EntireColumn.Address)) Then Exit Sub
Application.EnableEvents = False
If Not (Application.Intersect(Target, Range("C2:C5000", "P3:P5000")) _
Is Nothing) Then
On Error GoTo endItAll
For Each aCell In Target.Cells
Range(aCell.Address) = UCase(Range(aCell.Address))
Next aCell
End If
endItAll:
Application.EnableEvents = True
SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print SecondsElapsed
End Sub
Or you could change it back to the worksheet_Change macro like below and it will not error if the user selects multiple cells or deletes cells without causing an error. The error handler is there - Like in A.S.H. 's solution, but I haven't yet seen it needed in my testing.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not (Application.Intersect(Target, Range("C1:C5000", "D1:D5000")) _
Is Nothing) Then
On Error GoTo endItAll
For Each aCell In Target.Cells
Range(aCell.Address) = UCase(Range(aCell.Address))
Next aCell
End If
endItAll:
Application.EnableEvents = True
End Sub
Account for multiple cells this way:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Application.Intersect(Target, Range("C2:C5000", "P3:P5000")) _
Is Nothing) Then
Dim rCell as Range
Application.EnableEvents = False
For each rCell in Target
rCell.Value = UCase(rCell.Value)
Next
Application.EnableEvents = True
End If
End Sub
I have the following macro assigned to a button:
Sub refresh()
Application.Calculation = xlCalculationManual
ActiveWorkbook.RefreshAll
Application.Calculation = xlCalculationAutomatic
Call repeat
End Sub
Sub repeat()
TimeToRun = Now + TimeValue("00:05:00")
Application.OnTime TimeToRun, "refresh"
End Sub
If the button is clicked more than once, I get multiple instances of this macro running.
Is there a way to cancel any macros running prior to commencing the Sub refresh()?
Something like this:
Dim TimeToRun
Sub refresh()
Application.Calculation = xlCalculationManual
ActiveWorkbook.RefreshAll
Application.Calculation = xlCalculationAutomatic
Call repeat
End Sub
Sub repeat()
If TimeToRun > 0 Then
'cancel previous...
Application.OnTime TimeToRun, "refresh", False
End If
TimeToRun = Now + TimeValue("00:05:00")
Application.OnTime TimeToRun, "refresh"
End Sub
I tried to add the cancellation code in repeat but it did not work. I have added another sub that should run when the button is clicked. Range("G1") is a cell i use to store the time value.
Sub refresh()
Application.Calculation = xlCalculationManual
ActiveWorkbook.RefreshAll
Application.Calculation = xlCalculationAutomatic
Call repeat
End Sub
Sub repeat()
TimeToRun = Now + TimeValue("00:00:10")
'stoer the TimeToRun
Range("G1") = TimeToRun
'schedule the next refresh
Application.OnTime EarliestTime:=TimeToRun, Procedure:="refresh", Schedule:=True
End Sub
Sub subForClick()
If Not (IsEmpty(Range("G1"))) Then
Application.OnTime EarliestTime:=Range("G1").Value, Procedure:="refresh", Schedule:=False
End If
Call refresh
End Sub
Late for the party, but I create a function to check the time and let the user run the code again after some time.
Private Function timeCheck() As Boolean
If VBA.Now() > TimeControl.Range("A1").Value + VBA.TimeValue("00:05:00") Then
timeCheck = True
Else
timeCheck = False
End If
End Function
Where TimeControl is the name of the sheet that holds the time value on range A1.
So you just need to use this function as below:
If timeCheck = True Then
TimeControl.Range("A1").Value = VBA.Now()
do something
else
do something else
end if
I am trying to figure out why this "Delete Method of Range Class" error is popping up. It does not always occur when this macro runs, which makes it all the more perplexing.
Can anybody explain this?
Sub ResetSheet()
If WindowsOS Then
'*******************************************************************************************************'
'Resets the Data sheet. Called by the resetSheetButton procedure (located in module: m7_Macros1_5). '
'Also called by the OkCommandButton_Click procedure in the OnOpenUserForm form. '
'*******************************************************************************************************'
Application.EnableEvents = False
Sheet4.Visible = True
Sheet4.Activate
Sheet4.Select
Sheet4.Rows("2:101").Select
Selection.Copy
'TC Edit
Sheet1.Activate
Sheet1.Range("A2").PasteSpecial (xlPasteAll)
'Sheet1.Paste
Sheets("Data").Select
Sheet1.Rows("102:10000").EntireRow.Delete
Sheet4.Visible = False
'TC Edit 2.0 - Adding code to reset the exception checkboxes
If WindowsOS Then
Call resetCheckBoxes
End If
Application.EnableEvents = True
This is the macro code that causes the error (sometimes)
This is the error pop-up
try with below simplified code
Sub ResetSheet()
'If WindowsOS Then
Application.EnableEvents = False
With Worksheets("Sheet4")
.Visible = True
.Rows("2:101").Copy Worksheets("Sheet1").Range("A2")
End With
With Worksheets("Sheet1")
.Rows("102:101").EntireRow.Delete
End With
Worksheets("Sheet4").Visible = False
If windowsOS Then
Call resetCheckBoxes
End If
Application.EnableEvents = True
End Sub
I would like to prevent a user from stopping a macro during saving.
I have found the following code :
Application.EnableCancelKey = xlDisabled
It works if you hit the ESC key once, but if you hold the key a long time you can stop the macro.
I tried Application.EnableCancelKey = xlErrorHandler as follow :
Application.EnableCancelKey = xlErrorHandler
On Error GoTo errHandler:
ActiveWorkbook.Save
exitHere:
Exit Sub
errHandler:
msgbox"something"
Resume exitHere
Sometime it works perfectly, but sometimes if I hit the ESC key at the perfect moment and for a few seconds, I am able to stop the macro.
Do you know if there is a way to inactive ESC key for real?
I've never done this, but this is how I would start from your code:
On Error GoTo errHandler:
Application.EnableCancelKey = xlErrorHandler
ActiveWorkbook.Save
Application.EnableCancelKey = xlInterrupt
exitHere:
Exit Sub
errHandler:
If MsgBox("something", vbOKCancel) = vbCancel Then
Application.EnableCancelKey = xlInterrupt
Exit Sub
End If
Resume
I have a macro that checks if some names on column Q appear on column A (which is ordered alphabetically) and prints them out on column S if they do. However, every time I run it it freezes after an undefined amount of iterations (never on the same amount of iterations) so it's really hard to know what's going on. If I run it with a breaking point and press F5 for each iteration it doesn't freeze, the thing is I have thousands of names to compare and I really don't want to press F5 that many times.
Here's my code:
Sub test()
Range("Q2").Select
analizados = 0
falsos = 0
Do Until IsEmpty(ActiveCell)
id1 = ActiveCell.Value
primera = Left(id1, 1)
Range("A2").Select
Do While Not ActiveCell.Value Like "" & primera & "*"
ActiveCell.Offset(1, 0).Select
Loop
Do While ActiveCell.Value Like "" & primera & "*"
If id1 = ActiveCell.Value Then
Range("S2").Select
ActiveCell.Offset(falsos, 0).Select
ActiveCell.Value = id1
falsos = falsos + 1
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
analizados = analizados + 1
Range("Q2").Select
ActiveCell.Offset(analizados, 0).Select
Loop
End Sub
Thank you
As you noticed, it's not actually frozen. It's just that Excel can't keep up with updating the screen as fast as you're bombarding it with "something has changed on the active sheet" events, and at one point it gives up and lets the macro complete without bothering with refreshing - at least that's how I understand it (might not be exactly what's going on though).
Try this:
Sub Test()
On Error GoTo ErrHandler
Application.ScreenUpdating = False
'...
'(rest of your code)
'...
CleanExit:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume CleanExit
End Sub
Basically you tell Excel to not even bother with repainting itself until you're done: this should greatly speed up your loops.
You may want to combine this with different settings for Application.Calculation and Application.Cursor, too; and for a better UX you could use the status bar to tell the user to wait a little:
Sub Test()
On Error GoTo ErrHandler
Application.StatusBar = "Please wait..."
Application.ScreenUpdating = False
'...
'...
CleanExit:
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub