This code is supposed to take a number and find it's prime factors.
Why does this code work with numbers like 2345 (which returns 5, 7, 67 like its supposed to) but it doesn't work with numbers like 500 and 800?
EDIT: when I say it doesn't work, the program simply does nothing and/or freezes on button click. I then have to stop the program in vb.
Dim number As Double = txtNum.Text
Dim var As Double = 2
Dim result As Double
If number > 1 Then
lst1.Items.Clear()
lst1.Items.Add("The prime factors of " & number & ":")
Do While number > 1
result = number / var
If result = Int(result) Then
lst1.Items.Add(var)
number = result
End If
var = var + 1
Loop
Else
lst1.Items.Clear()
lst1.Items.Add("Let try that again...")
End If
The problem was caused because 500 divided by 2 is 250, divided by 5 is 50 ... and then the program continued on by dividing by 6 instead of attempting to divide by 5 again. Once var reached 10, number became 5 and no further divisions ever allowed it to reach 1 - thus an infinite loop was created.
By changing
If result = Int(result) Then
lst1.Items.Add(var)
number = result
End If
var = var + 1
to
If result = Int(result) Then
lst1.Items.Add(var)
number = result
Else
var = var + 1
End If
it correctly made multiple divisions by the same prime factor when necessary.
i want to repeat an event after a certain duration that is less than 1 second. I tried using the following code
Application.wait Now + TimeValue ("00:00:01")
But here the minimum delay time is one second. How to give a delay of say half a seond?
You can use an API call and Sleep:
Put this at the top of your module:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Then you can call it in a procedure like this:
Sub test()
Dim i As Long
For i = 1 To 10
Debug.Print Now()
Sleep 500 'wait 0.5 seconds
Next i
End Sub
I found this on another site not sure if it works or not.
Application.Wait Now + 1/(24*60*60.0*2)
the numerical value 1 = 1 day
1/24 is one hour
1/(24*60) is one minute
so 1/(24*60*60*2) is 1/2 second
You need to use a decimal point somewhere to force a floating point number
Source
Not sure if this will work worth a shot for milliseconds
Application.Wait (Now + 0.000001)
call waitfor(.005)
Sub WaitFor(NumOfSeconds As Single)
Dim SngSec as Single
SngSec=Timer + NumOfSeconds
Do while timer < sngsec
DoEvents
Loop
End sub
source
Timing Delays in VBA
I have try this and it works for me:
Private Sub DelayMs(ms As Long)
Debug.Print TimeValue(Now)
Application.Wait (Now + (ms * 0.00000001))
Debug.Print TimeValue(Now)
End Sub
Private Sub test()
Call DelayMs (2000) 'test code with delay of 2 seconds, see debug window
End Sub
Everyone tries Application.Wait, but that's not really reliable. If you ask it to wait for less than a second, you'll get anything between 0 and 1, but closer to 10 seconds. Here's a demonstration using a wait of 0.5 seconds:
Sub TestWait()
Dim i As Long
For i = 1 To 5
Dim t As Double
t = Timer
Application.Wait Now + TimeValue("0:00:00") / 2
Debug.Print Timer - t
Next
End Sub
Here's the output, an average of 0.0015625 seconds:
0
0
0
0.0078125
0
Admittedly, Timer may not be the ideal way to measure these events, but you get the idea.
The Timer approach is better:
Sub TestTimer()
Dim i As Long
For i = 1 To 5
Dim t As Double
t = Timer
Do Until Timer - t >= 0.5
DoEvents
Loop
Debug.Print Timer - t
Next
End Sub
And the results average is very close to 0.5 seconds:
0.5
0.5
0.5
0.5
0.5
Obviously an old post, but this seems to be working for me....
Application.Wait (Now + TimeValue("0:00:01") / 1000)
Divide by whatever you need. A tenth, a hundredth, etc. all seem to work. By removing the "divide by" portion, the macro does take longer to run, so therefore, with no errors present, I have to believe it works.
No answer helped me, so I build this.
' function Timestamp return current time in milliseconds.
' compatible with JSON or JavaScript Date objects.
Public Function Timestamp () As Currency
timestamp = (Round(Now(), 0) * 24 * 60 * 60 + Timer()) * 1000
End Function
' function Sleep let system execute other programs while the milliseconds are not elapsed.
Public Function Sleep(milliseconds As Currency)
If milliseconds < 0 Then Exit Function
Dim start As Currency
start = Timestamp ()
While (Timestamp () < milliseconds + start)
DoEvents
Wend
End Function
Note : In Excel 2007, Now() send Double with decimals to seconds, so i use Timer() to get milliseconds.
Note : Application.Wait() accept seconds and no under (i.e. Application.Wait(Now()) ↔ Application.Wait(Now()+100*millisecond)))
Note : Application.Wait() doesn't let system execute other program but hardly reduce performance. Prefer usage of DoEvents.
Otherwise you can create your own function then call it. It is important to use Double
Function sov(sekunder As Double) As Double
starting_time = Timer
Do
DoEvents
Loop Until (Timer - starting_time) >= sekunder
End Function
To pause for 0.8 of a second:
Sub main()
startTime = Timer
Do
Loop Until Timer - startTime >= 0.8
End Sub
Public Function CheckWholeNumber(Number As Double) As Boolean
If Number - Fix(Number) = 0 Then
CheckWholeNumber = True
End If
End Function
Public Sub TimeDelay(Days As Double, Hours As Double, Minutes As Double, Seconds As Double)
If CheckWholeNumber(Days) = False Then
Hours = Hours + (Days - Fix(Days)) * 24
Days = Fix(Days)
End If
If CheckWholeNumber(Hours) = False Then
Minutes = Minutes + (Hours - Fix(Hours)) * 60
Hours = Fix(Hours)
End If
If CheckWholeNumber(Minutes) = False Then
Seconds = Seconds + (Minutes - Fix(Minutes)) * 60
Minutes = Fix(Minutes)
End If
If Seconds >= 60 Then
Seconds = Seconds - 60
Minutes = Minutes + 1
End If
If Minutes >= 60 Then
Minutes = Minutes - 60
Hours = Hours + 1
End If
If Hours >= 24 Then
Hours = Hours - 24
Days = Days + 1
End If
Application.Wait _
( _
Now + _
TimeSerial(Hours + Days * 24, Minutes, 0) + _
Seconds * TimeSerial(0, 0, 1) _
)
End Sub
example:
call TimeDelay(1.9,23.9,59.9,59.9999999)
hopy you enjoy.
edit:
here's one without any additional functions, for people who like it being faster
Public Sub WaitTime(Days As Double, Hours As Double, Minutes As Double, Seconds As Double)
If Days - Fix(Days) > 0 Then
Hours = Hours + (Days - Fix(Days)) * 24
Days = Fix(Days)
End If
If Hours - Fix(Hours) > 0 Then
Minutes = Minutes + (Hours - Fix(Hours)) * 60
Hours = Fix(Hours)
End If
If Minutes - Fix(Minutes) > 0 Then
Seconds = Seconds + (Minutes - Fix(Minutes)) * 60
Minutes = Fix(Minutes)
End If
If Seconds >= 60 Then
Seconds = Seconds - 60
Minutes = Minutes + 1
End If
If Minutes >= 60 Then
Minutes = Minutes - 60
Hours = Hours + 1
End If
If Hours >= 24 Then
Hours = Hours - 24
Days = Days + 1
End If
Application.Wait _
( _
Now + _
TimeSerial(Hours + Days * 24, Minutes, 0) + _
Seconds * TimeSerial(0, 0, 1) _
)
End Sub
I am requesting assistance as to why the last outer loop of the following code is omitted. This code is part of a healthcare simulation, which uses VBA to iterate through combinations of parameters to generate sensitivity analyses. I have 3 other sensitivity analyses operating without issue. Notably, the sub call_transplant_surv is a highly conserved program that operates without issue in many other operatiions not shown here. I have tried skeletonizing the code to isolate the issue without success. I have not noted an error on the sheets that would cause failure at certain values of txp1b.
Sub twoway1()
'delay in list and 1B VAD txp rate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
Dim i As Long, j As Long, counter As Long
Dim prob_bin As Byte, delay_list As Byte, status_2_bin As Byte, elective_days As Byte, first_day As Byte
Dim timestart As Double, timeall As Double, twoway1 As Integer, twoway2 As Integer, delay_i As Integer
'begin time counter
timestart = Time
'set values
prob_bin = 0 'probabilistic model = 1
delay_list = 0 'set to to begin at 30 given loop
status_2_bin = 0 'normal values = 0
elective_days = 30 'fixed value of 1A days allowed
first_day = 30 'first day elective time is used, incremented in the macro w/o a variable
posttxp_death = 1
twoway1 = 1
twoway2 = 0
txp1b = 0
delay_i = 0
time_measure = 0 'measurement time (e.g. at 0 days all parameters are measured, 30 days all measured, etc.)
timemeas_inc = 30 'increment of the measurement time (e.g. every 30 days- 30, 60, 90,....
counter = 1
'enter settings into model
Sheets("settings").Range("C27").Value = prob_bin
Sheets("settings").Range("C28").Value = delay_list
Sheets("settings").Range("C29").Value = status_2_bin
Sheets("settings").Range("C30").Value = elective_days
Sheets("settings").Range("C31").Value = first_day
Sheets("settings").Range("C32").Value = posttxp_death
Sheets("settings").Range("C44").Value = twoway1
Sheets("settings").Range("C45").Value = twoway2
calculate
'enter two loops to control the parameters
'enter two loops to control the parameters
For txp1b = 0.05 To 0.3 Step 0.05
For delay_i = 0 To 360 Step 90
Sheets("settings").Range("C31").Value = delay_i + 30
Sheets("settings").Range("C28").Value = delay_i
Sheets("1B>TXP Weib").Range("J20").Value = txp1b
calculate
'transplant survival calcs
call_txp_surv
'enter measurement loop
For i = 1 To 61
'place time measured
Sheets("settings").Range("AD4").Value = time_measure
'speed up calcs part 2
calculate
'record simulation results into sheet delay_list Row/column
Sheets("twoway1").Activate
Sheets("twoway1").Range(Cells(counter + 1, 1), Cells(counter + 1, 45)).Value = Sheets("settings").Range("M4:BE4").Value
'increment the time point for data recording
time_measure = time_measure + timemeas_inc
'increment counter for correct placement of next loop of results
counter = counter + 1
Next i
time_measure = 0
Next
Next
time_all = Time - timestart
'Sheets("twoway1").Range("AU2").Value = time_all
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
End Sub
The issue is using a non-integer loop counter - my guess is that the loop is exiting early because of a floating point error:
Private Sub Example()
Dim i As Double
For i = 0.05 To 0.3 Step 0.05
Debug.Print i
Next
End Sub
My recommendation would be to use integer iterations and then calculate the working value separately:
Dim i As Long
For i = 1 To 6
txp1b = i * 0.05
'...
Next
I have a VBA function (DecTime) that I call passing in the value of a cell. The cell is formatted as custom hh:mm
in my cell the formula is "=DecTime(M6)"
If M6 is a time, eg 01:05 then it works fine, if it is null then I get #VALUE!
I am sure it's a simple solution but having spent the last hour trying lots of things from here and google I am baffled!
Here is my function :
Function DecTime(Optional time As Date = #12:00:00 AM#) As Single 'String
Dim Hours As Integer
Dim Minutes As Single
Dim HoursStr As String
Dim arrTime
'On Error Resume Next
'On Error GoTo error_handler
' HoursStr = Format(time, "h:mm")
' DecTime = HoursStr
If time = #12:00:00 AM# Then
' If HoursStr = "12:00" Then
' If IsEmpty(time) Then
' If IsEmpty(time) = True Then
' If IsNull(time) Then
' If arrTime.Count = 0 Then
' If InStr(0, time, ":") = 0 Then
' If IsDate(time) = False Then
DecTime = 88
' DecTime = HoursStr
Else
arrTime = Split(time, ":")
If arrTime(1) <= 0 Then
Minutes = 0
ElseIf arrTime(1) <= 5 Then
Minutes = 0.1
ElseIf arrTime(1) <= 10 Then
Minutes = 0.2
ElseIf arrTime(1) <= 15 Then
Minutes = 0.3
ElseIf arrTime(1) <= 20 Then
Minutes = 0.3
ElseIf arrTime(1) <= 25 Then
Minutes = 0.4
ElseIf arrTime(1) <= 30 Then
Minutes = 0.5
ElseIf arrTime(1) <= 35 Then
Minutes = 0.6
ElseIf arrTime(1) <= 40 Then
Minutes = 0.7
ElseIf arrTime(1) <= 45 Then
Minutes = 0.8
ElseIf arrTime(1) <= 50 Then
Minutes = 0.8
ElseIf arrTime(1) <= 55 Then
Minutes = 0.9
Else
Minutes = 0
End If
Hours = arrTime(0)
DecTime = Hours + Minutes
' DecTime = HoursStr
End If
'error_handler:
' DecTime = 99
'Resume Next
End Function
As you can see from the remarked code I have tried lots of different options to deal with a blank parameter passed in so if someone can tell me what I've done wrong I'd be very greatful!
I am a sql programmer so not much experience with VB
Assuming you want to return 0 if the cell is empty or doesn't contain a date, you could use:
Function DecTime(Optional time = #12:00:00 AM#) As Double
Dim Hours As Integer
Dim Minutes As Single
Dim arrTime
If Not IsDate(time) Then
DecTime = 0
ElseIf time = #12:00:00 AM# Then
DecTime = 0
Else
arrTime = Split(time, ":")
Select Case arrTime(1)
Case Is = 0
Minutes = 0
Case Is <= 5
Minutes = 0.1
Case Is <= 10
Minutes = 0.2
Case Is <= 20
Minutes = 0.3
Case Is <= 25
Minutes = 0.4
Case Is <= 30
Minutes = 0.5
Case Is <= 35
Minutes = 0.6
Case Is <= 40
Minutes = 0.7
Case Is <= 50
Minutes = 0.8
Case Is <= 55
Minutes = 0.9
Case Else
Minutes = 0
End Select
Hours = arrTime(0)
DecTime = Hours + Minutes
End If
End Function
Here is my code:
number = 1
If chkFN.Enabled = True Then
If ProgressBar1.Value < 100 Then
number += 1
lblFN2.Text = number
Else
lblFN2.Text = "0"
End If
End If
i have a checkbox, progressbar and a label.
when the progress bar is lower than 100 i want the number variable to + 1 every time the timer counts 1. I've tried "X = X + 1" - it worked to a point but i need to reset the variable to "0" when the progressbar hits 100% and when i click the stop button.
while I've been typing this i've also tried:
X = X + 1
If chkFN.Enabled = True Then
If ProgressBar1.Value < 100 Then
lblFN2.Text = X + 1
ElseIf AxWindowsMediaPlayer1.playState = WMPLib.WMPPlayState.wmppsMediaEnded
Then
X = 0
lblFN2.Text = "0"
Else
X = 0
lblFN2.Text = "0"
End If
End If
But when you start the timer again it just resumes from it's last number e.g. "13" and doesn't reset to "0".
Thanks for the help guys :)
Use your first code, but add in
number += 1
to the Else condition. You need to reset the variable or it just increments it again.