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
Related
I am trying to ad a activity (in this example print time) after every 5 second by following code.
Sub tr1()
dim i as Integer
i = Range("b1").Value
If i < 3 Then
Application.OnTime Now + TimeValue("00:00:05"), "tr2", , True
End If
Range("a" & i).Value = UCase(Format(Now, "HH:MM:SS"))
Range("b1").Value = Range("b1").Value + 1
MsgBox ("tr1 called")
End Sub
Sub tr2()
Application.OnTime Now + TimeValue("00:00:05"), "tr1"
MsgBox ("tr2 called")
End Sub
on running tr1, I am getting following error:
after 5 seconds. Please, let me what am I doing wrong.
You have to refer the module as well. This will work, if the code is in Module1:
Sub tr1()
Application.OnTime Now + TimeValue("00:00:01"), "!Module1.tr2", , True
End Sub
Sub tr2()
MsgBox "tr2"
End Sub
If it is in a worksheet, the correspondingly:
Sub tr1()
Application.OnTime Now + TimeValue("00:00:01"), "!Sheet1.tr2", , True
End Sub
Sub tr2()
MsgBox "tr2"
End Sub
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.
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 code that loads a worksheet in full screen for 1 minute, and then moves onto the next worksheet in the workbook, using the exactly the same methodology.
This is to show stats on a big screen, looping through several stats pages.
This works perfectly on Excel 2007 and 2010.
Yet when the same code is executed on Excel 2013, Excel simply maxes out 1 core of my CPU and stays at not responding. I cannot even Escape to break the code execution. Stepping through the code line by line works fine on all versions.
'Loads up Daily Dispatch Figures worksheet
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
Range("A1").Select
Range("A1:C36").Select
ActiveWindow.Zoom = True
Range("A1").Select
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
Application.DisplayFullScreen = True
Application.ScreenUpdating = True
' Stays on this screen for 1 min
TimVal = Now + TimeValue("0:01:00")
Do Until Now >= TimVal
Loop
Ooo, don't do this:
' Stays on this screen for 1 min
TimVal = Now + TimeValue("0:01:00")
Do Until Now >= TimVal
Loop
Try this:
Application.OnTime Now + TimeValue("0:01:00"), "ProcedureToRun"
You don't want to catch your application in an infinite loop with no sleeps.
Any time you sit in an infinite loop without sleeping, it will use 100% of your Processor time doing nothing. Application.OnTime "schedules" an event and returns control to the Excel UI Thread instead of infinitely looping.
You can read more here: https://msdn.microsoft.com/en-us/library/office/ff196165.aspx
I'm not sure what you're doing after your loop, but you need to make sure you have the code in a separate subroutine and call it.
Here is a Subroutine to go to the next sheet.
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
End Sub
You can add the Application.OnTime to the end of it and have it call itself:
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
Application.OnTime Now + TimeValue("00:01:00"), MoveNext
End Sub
This way it will loop and go from sheet to sheet forever (or until you stop it in whatever method you choose to use).
Finally, you can cancel this by storing the scheduled time and using Scheduled:=False.
Your final code could look something like this:
Public scheduledTime as Date
Sub StartDisplaying()
'Your start code:
'---------------------------------------------
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
Range("A1").Select
Range("A1:C36").Select
ActiveWindow.Zoom = True
Range("A1").Select
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
Application.DisplayFullScreen = True
Application.ScreenUpdating = True
'---------------------------------------------
scheduledTime = Now + TimeValue("00:01:00")
Application.OnTime scheduledTime, MoveNext
End Sub
Sub StopDisplaying()
'Your stop code:
'---------------------------------------------
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
ActiveWindow.Zoom = False
ActiveWindow.DisplayHeadings = True
Application.DisplayFormulaBar = True
Application.DisplayFullScreen = False
Application.ScreenUpdating = True
'---------------------------------------------
Application.OnTime EarliestTime:=scheduledTime, Procedure:="MoveNext", Schedule:=False
End Sub
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
scheduledTime = Now + TimeValue("00:01:00")
Application.OnTime scheduledTime, MoveNext
End Sub
I have a code to copy a range and paste the values.
This is done in a time interval after I click a command button.
How do I stop or pause this macro by clicking a button?
Here is the main code:
Sub timestamp()
'
' timestamp Macro
'
N = WorksheetFunction.Count(Sheets("DNB").Columns(1))
dnbspread = Sheets("DNB").Range("G5:G30")
Sheets("DNB").Cells(N + 34, 1) = Date
Sheets("DNB").Cells(N + 34, 2) = Time
Sheets("DNB").Range("G5:G30").Copy
Sheets("DNB").Cells(N + 34, 3).PasteSpecial Transpose:=True, Paste:=xlPasteValues
Application.OnTime Now + TimeValue("00:00:05"), "timestamp"
End Sub
I tried a couple of things.
by BREAK function
Sub PauseMacro()
Application.SendKeys "^{BREAK}"
End Sub
2.
Public StopMacro as Boolean
Sub SetStopMacro()
StopMacro = True
End Sub
and put it in the code as this:
Sub timestamp()
'
' timestamp Macro
'
N = WorksheetFunction.Count(Sheets("DNB").Columns(1))
dnbspread = Sheets("DNB").Range("G5:G30")
Sheets("DNB").Cells(N + 34, 1) = Date
Sheets("DNB").Cells(N + 34, 2) = Time
Sheets("DNB").Range("G5:G30").Copy
Sheets("DNB").Cells(N + 34, 3).PasteSpecial Transpose:=True, Paste:=xlPasteValues
Application.OnTime Now + TimeValue("00:00:10"), "timestamp"
DoEvents
If StopMacro = True Then Exit Sub
End Sub
Public StopMacro As Boolean
Sub SetStopMacro()
StopMacro = True
End Sub
Sub timestamp()
'
' timestamp Macro
'
' code here
'
' Put If-Then before Application.OnTime call.
' So prevent next call of 'timestamp()' if StopMacro equals to true
If Not StopMacro Then
Application.OnTime Now + TimeValue("00:00:15"), "timestamp"
End If
End Sub
You can declare a global variable inside the module where the macro is running from, and then, when the command button is clicked, assign a value to that variable you just declared. Then, create an if statement, where the code exits if the variable equals to that value.
Private Sub CommandButton2_Click()
btncancel = 1
EMSetup.hide
Exit Sub
End Sub
For the command button.
Global btncancel As Integer
If btncancel = 1 Then
Exit Sub
End If
Hope this helps!