I would like to make a countdown, so I've set a cell, E1 with time format, and given 0:02:55 as start time. After that I try to make coutdown after button click with this code, but got an error, that it isn't runnable.
Sub Timer()
Dim gCount As Date
gCount = Now + TimeValue("00:00:01")
Application.OnTime gCount, "ResetTime"
End Sub
Sub ResetTime()
Dim xRng As Range
Set xRng = Application.ActiveSheet.Range("E1")
xRng.Value = xRng.Value - TimeSerial(0, 0, 1)
If xRng.Value <= 0 Then
MsgBox "Countdown complete."
Exit Sub
End If
Call Timer
End Sub
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 want to make a macro that has an infinite loop. in this loop, I change values of cells every second.
I want to manually change a cell without stopping the macro (Alpha variable in the code). Is there any workaround to make it possible ? or threads ?
here is my code :
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Integer
i = 0
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set P1 = ws.Range("A1")
Set Q1 = ws.Range("A2")
Set Alpha = ws.Range("G1")
On Error GoTo CleanExit
If Target.Address = "$Q$21" Then
Application.EnableEvents = False
End If
CleanExit:
Application.EnableEvents = True
While i = 0
P1.Value = 100 + WorksheetFunction.RandBetween(1, 6)
Q1.Value = Alpha
Pause (1)
Wend
On Error GoTo 0
End Sub
and here is the Pause function:
Public Function Pause(NumberOfSeconds As Variant)
On Error GoTo Error_GoTo
Dim PauseTime As Variant
Dim Start As Variant
Dim Elapsed As Variant
PauseTime = NumberOfSeconds
Start = Timer
Elapsed = 0
Do While Timer < Start + PauseTime
Elapsed = Elapsed + 1
If Timer = 0 Then
' Crossing midnight
PauseTime = PauseTime - Elapsed
Start = 0
Elapsed = 0
End If
DoEvents
Loop
Exit_GoTo:
On Error GoTo 0
Exit Function
Error_GoTo:
Debug.Print Err.Number, Err.Description, Erl
GoTo Exit_GoTo
End Function
When I select the cell, I get the Error 1004 "Application-defined or Object-defined error"
Basically, I want to simulate the functioning of hydraulic pump, there is an angle alpha that varies. If alpha changes the other parameters (pressure , flow ...) change. that's why I want to make a continuous loop on the parameter with some error every second(with the random function). When alpha changes (manually), The parameter change the value.That is the main Idea.
For repeated Calculations using data from the worksheet I would use a construction like the following. It uses the Application.OnTime Event to run the procedure repeatedly (~ every second) until some condition is met (or a stop precedure is called). I used some simple code to show that you can enter data in the worksheet:
Option Explicit
Private Running As Boolean
Sub Start_Timer()
Running = True
Application.OnTime Now + TimeSerial(0, 0, 1), "Timed_Code"
End Sub
Sub Stop_Timer()
Running = False
End Sub
Sub Timed_Code()
If [A1] = False Then Call Stop_Timer
[C1] = [B1] + Application.WorksheetFunction.RandBetween(1, 6)
If Running Then Application.OnTime Now + TimeSerial(0, 0, 1), "Timed_Code"
End Sub
I have this macro that pulls out data from a website. I get the inputs from a user-from. It works with no error but IE won't close and sucks up all of the memory. Is something else needed rather than IE.Quit?
This is the sub. As you can see I close IE at the end.
Public Cancel As Boolean
Sub USGD()
Dim IE As Object
Dim iWsh As Worksheet
Dim link As String
Dim sDate As String
Dim eDate As String
Dim StationID As String
Cancel = False
With USGS
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
If Cancel = True Then
Unload USGS
Exit Sub
End If
With ActiveWorkbook
Set iWsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))
End With
iWsh.Activate
iWsh.Range("A1").Select 'I know this is not efficient but works fine
StationID = USGS.TextBox1.Text
'StationID = InputBox("Please enter the station ID")
'sDate = InputBox("Please enter START date in this format: 'yyyy-mm-dd'")
'eDate = InputBox("Please enter END date in this format: 'yyyy-mm-dd'")
sDate = Format(USGS.TextBox2.Text, "yyyy-mm-dd")
eDate = Format(USGS.TextBox3.Text, "yyyy-mm-dd")
link = "https://waterdata.usgs.gov/ & _
StationID & sDate & eDate
Unload USGS
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = False
.Navigate link 'URL
Do Until .ReadyState = 4: DoEvents: Loop
.ExecWB 17, 0 '// SelectAll
.ExecWB 12, 2 '// Copy selection
End With
iWsh.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
Range("A1").Select
IE.Quit
Set IE = Nothing
Set iWsh = Nothing
End Sub
And this is the user-form: I didn't have this problem while using Input-Box so I am guessing, it has something to do with the user-form. This only happens when user closes the user-form.
Private Sub ToggleButton1_Click()
Me.Hide
Cancel = True
End Sub
Private Sub OK_Click()
Me.Hide
End Sub
Note: If the user cancel, it would not even open the IE and exits the sub right after.
But if user closes the form, it does open IE, and doesn't set the Cancel to be True which is the condition to exit the sub.
Update: Expert-Exchange covered the issue but never came up with an actual solution.
Update-2: Closing all instances of IE is not an option.
This is how user-form is set up now:
OK so I am unable to replicate the error, so there are two things you should try:
Reboot your computer and verify the error continues. If not, problem solved.
Recreate the UserForm & code in a new, blank workbook, and see if the error continues. If not, problem solved.
(Sometimes Workbooks, and/or UserForms become corrupted)
I also re-factored the code a little bit, which you might consider even if one of the above suggestions solves the problem. It just cleans it up a little bit and makes it more purposeful.
In a standard module, place the following code:
The USGD procedure displays the userform and unloads it. A separate procedure named GetData will do the work in IE and add the worksheet, etc. The GetData procedure is only executed if the user clicks on the "OK" button on the form. Therefore, the "X"/cancel button will allow the user to close the form.
Option Explicit
Sub USGD()
'Procedure displays the userform for the user
Dim USGSForm As New USGS
With USGSForm
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
Unload USGSForm
End Sub
Sub GetData(StationID As String, sDate As String, eDate As String)
'This procedure queries the InternetExplorer for the values from UserForm
Dim iWsh As Worksheet
Dim link As String
Dim IE As Object
sDate = Format(sDate, "yyyy-mm-dd")
eDate = Format(eDate, "yyyy-mm-dd")
link = "https://waterdata.usgs.gov/nwis/dv?cb_00060=on&format=rdb&site_no=" & _
StationID & "&referred_module=sw&period=&begin_date=" & sDate & "&end_date=" & eDate
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = False
.Navigate link 'URL
Do Until .ReadyState = 4: DoEvents: Loop
.ExecWB 17, 0 '// SelectAll
.ExecWB 12, 2 '// Copy selection
.Quit
End With
With ActiveWorkbook
Set iWsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))
End With
iWsh.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
Application.GoTo iWsh.Range("A1")
End Sub
In your UserForm module, place the following code:
This is the code for the "OK" button, which takes the values from TextBoxes on the form and sends those to the GetData procedure. Note the Select Case logic which will exit the procedure early if any of the parameters are empty, so it will not call GetData.
Private Sub OK_Click()
Dim id As String, sDate As String, eDate As String
'Get values from the form
id = Me.TextBox1.Value
sDate = Me.TextBox2.Value
eDate = Me.TextBox3.Value
'Hide the form
Me.Hide
'If ANY required parameter is blank, this results in malformed URL so exit the procedure
Select Case vbNullString
Case id, sDate, eDate
MsgBox "You left some parameter blank, no query will be performed.", vbInformation
GoTo EarlyExit
Case Else
'Send values to the procedure that queries IE
Call GetData(id, sDate, eDate)
End Select
EarlyExit:
End Sub
I found a workaround but not a good answer. Also, does not explain why that happens.
I changed my user-form so the user cannot close it. Also set the initial value of Cancel to be True
Cancel = True
and when the use pushes OK it will be set to false. Look below for the user form code:
Private Sub ToggleButton1_Click()
End Sub
Private Sub OK_Click()
Me.Hide
Cancel = False
End Sub
Obvious downside of this is that users cannot close the user-form; they have to hit OK. This won't cause an error. I just can add a condition that if one of the text boxes was empty then exit the sub. Something like below;
If sDate = "" Or eDate = "" Or StationID = "" Then GoTo 92
'. Rest of ...
'. My ...
'. Code ...
92:
Set IE = Nothing
End Sub
I am creating a user form that does Customer Returns. I wish to have a (Status)column that will automatically update itself. It refers to the Arrival Date of the product. It works, but, when I change the system date, the status bar does not change. What do I have to do to make it update regularly? The following is the code of what ever is working.
P.S it the code works fine when entering the values. But doesn't self update
Option Explicit
Dim dDate As Date
Private Sub cbP_CodeCR_Change()
Dim row As Long
row = cbP_CodeCR.ListIndex + 2
End Sub
Private Sub Fill_My_Combo(cbo As ComboBox)
Dim wsInventory As Worksheet
Dim nLastRow As Long
Dim i As Long
Set wsInventory = Worksheets("Inventory")
nLastRow = wsInventory.Cells(Rows.Count, 1).End(xlUp).row ' Finds last row in Column 1
cbo.Clear
For i = 2 To nLastRow 'start at row 2
cbo.AddItem wsInventory.Cells(i, 1)
Next i
End Sub
Private Sub cmdCancel_Click()
Unload CustomerReturn
End Sub
Private Sub cmdEnter_Click()
Dim cust_ID As Integer
Dim prod_Code As Integer
Dim arr_date As Date
Dim stat As String
Dim status As String
Dim rowPosition As Integer
rowPosition = 1
Sheets("Customer Return").Select
Sheets("Customer Return").Cells(1, 1).Value = "Customer ID"
Sheets("Customer Return").Cells(1, 2).Value = "Product Code"
Sheets("Customer Return").Cells(1, 3).Value = "Arrival Date"
Sheets("Customer Return").Cells(1, 4).Value = "Status"
Do While (Len(Worksheets("Customer Return").Cells(rowPosition, 1).Value) <> 0)
rowPosition = rowPosition + 1
Loop
cust_ID = txtC_IDCR.Text
Sheets("Customer Return").Cells(rowPosition, 1).Value = cust_ID
prod_Code = cbP_CodeCR.Text
Sheets("Customer Return").Cells(rowPosition, 2).Value = prod_Code
arr_date = txtA_DateCR.Text
Sheets("Customer Return").Cells(rowPosition, 3).Value = arr_date
If ((arr_date - Date) <= 0) Then
Sheets("Customer Return").Cells(rowPosition, 4).Value = "Arrived"
Else
Sheets("Customer Return").Cells(rowPosition, 4).Value = "Waiting for Delivery"
End If
End Sub
Sub Recalc()
Range("C:C").Value = Format("dd/mm/yyyy")
Range("D:D").Calculate
Call StartTime
End Sub
Sub StartTime()
SchedRecalc = Now + TimeValue("00:00:10")
Application.OnTime SchedRecalc, "Recalc"
End Sub
Sub EndTime()
On Error Resume Next
Application.OnTime EarliestTime:=SchedRecalc, _
Procedure:="Recalc", Schedule:=False
End Sub
Private Sub txtA_DateCR_AfterUpdate()
With txtA_DateCR
If .Text = "" Then
.ForeColor = &HC0C0C0
.Text = "dd/mm/yyyy"
End If
End With
End Sub
Private Sub txtA_DateCR_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Exit Sub
If Mid(txtA_DateCR.Value, 4, 2) > 12 Then
MsgBox "Invalid date, make sure format is (dd/mm/yyyy)", vbCritical
txtA_DateCR.Value = vbNullString
txtA_DateCR.SetFocus
Exit Sub
End If
dDate = DateSerial(Year(Date), Month(Date), Day(Date))
txtA_DateCR.Value = Format(txtA_DateCR.Value, "dd/mm/yyyy")
dDate = txtA_DateCR.Value
End Sub
Private Sub txtA_DateCR_Enter()
With txtA_DateCR
If .Text = "dd/mm/yyyy" Then
.ForeColor = &H80000008
.Text = ""
End If
End With
End Sub
Private Sub UserForm_Initialize()
txtA_DateCR.ForeColor = &HC0C0C0
txtA_DateCR.Text = "dd/mm/yyyy"
cmdEnter.SetFocus
Fill_My_Combo Me.cbP_CodeCR
End Sub
Deeply appreciate any help if possible.
This should work in the most common scenario when time flows forward:
Create a utility module AnyNameIsGood with this code (it comes from Sean Cheshire's answer to similar question with the Recalc body adjusted)
Dim ScheduledRecalc As Date
Sub Recalc()
Sheets("Customer Return").Range("D:D").Calculate
Call StartTime
End Sub
Sub StartTime()
ScheduledRecalc = Now + TimeValue("00:00:10")
Application.OnTime ScheduledRecalc, "Recalc"
End Sub
Sub EndTime()
On Error Resume Next
Application.OnTime EarliestTime:=ScheduledRecalc, Procedure:="Recalc", Schedule:=False
End Sub
Add this code to the ThisWorkbook module to prevent unwanted behavior while closing the module:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call EndTime
End Sub
In the CustomerReturn module (the form) change your current code to
Private Sub cmdEnter_Click()
' ...
arr_date = txtA_DateCR.Text
Sheets("Customer Return").Cells(rowPosition, 3).Value = arr_date
Sheets("Customer Return").Cells(rowPosition, 3).NumberFormat = "dd\/mm\/yyyy"
Sheets("Customer Return").Cells(rowPosition, 4).FormulaR1C1 = "=IF(DAYS(R[0]C[-1],TODAY())<=0,""Arrived"",""Waiting for Delivery"")"
End Sub
It will format the date cells and it will make the generated Status formulas sensitive to the Excel's Calculate Now (F9) event.
Somewhere (e.g. in the Workbook_Open event handler) call the StartTime utility procedure (once). It will trigger automatic recalculation of the Status column.
Steps 1, 2, 4 are optional and not needed if the refresh does not have to be automatic as the end user can refresh the statuses anytime by pressing F9
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!