A function returns a MsgBox 10 times? - vba

Found a function on Excelguru which I changed a few things in and gonna edit some more. The idea is to use this to register worked hours and minutes.
There is one thing in this I don't understand: if I type the wrong time in the column reff I get a msg that its wrong, but it wont disappear unless I click it 10 times. I cant see what Im doing wrong. The entire code is posted and Im grateful for any help.
Use his function as part of the formula in the sheet like: TimeValue($E2;$F2;"16:00";"18:00";B2;9;C2)
Function TimeValue(FromTime As String, ToTime As String, StartTime As String, StopTime As String, Optional Weekday As String, Optional Daynr As Integer, Optional Holiday As String)
Dim x As Long
Dim F As Double
Dim T As Double
Dim Start As Double
Dim Stopp As Double
Dim Min As Long
Dim Day As Integer
Dim OverMid As Boolean
Select Case LCase(Weekday)
Case "mandag"
Day = 1
Case "tirsdag"
Day = 2
Case "onsdag"
Day = 3
Case "torsdag"
Day = 4
Case "fredag"
Day = 5
Case "lordag"
Day = 6
Case "sondag"
Day = 7
Case "x"
Day = 8
Case Else
Day = 0
End Select
OverMid = False
If LCase(Holiday) = "x" Then Day = 8
If Len(FromTime) = 0 Or Len(ToTime) = 0 Then
Exit Function
End If
If Len(FromTime) <> 5 Then
MsgBox ("Use format TT:MM - From time is wrong:" & FromTime)
Exit Function
End If
If Len(ToTime) <> 5 Then
MsgBox ("Use format TT:MM - To time is wrong:" & ToTime)
Exit Function
End If
F = Val(Left(FromTime, 2)) * 60 + Val(Right(FromTime, 2))
T = Val(Left(ToTime, 2)) * 60 + Val(Right(ToTime, 2))
Start = Val(Left(StartTime, 2)) * 60 + Val(Right(StartTime, 2))
Stopp = Val(Left(StopTime, 2)) * 60 + Val(Right(StopTime, 2))
If T = 0 Then T = 24 * 60
If T < F Then
T = T + 24 * 60
OverMid = True
End If
If Stopp = 0 Then Stopp = 24 * 60
For x = F + 1 To T
If x > Start And x <= Stopp Then
Min = Min + 1
End If
Next x
If OverMid = True Then
For x = 0 To Val(Left(ToTime, 2)) * 60 + Val(Right(ToTime, 2))
If x > Start And x <= Stopp Then
Min = Min + 1
End If
Next x
End If
'If weekday is set, equal to day
If Daynr <> 0 Then
If Daynr <> 9 Then
If Day <> Daynr Then Min = 0
End If
If Daynr = 9 And (Day > 5) Then
Min = 0
End If
End If
TimeValue = Min / 60
End Function
And the sub in the sheets
Private Sub Worksheet_Change(ByVal Target As Range)
Dim streng As String
Dim k As Long
Dim r As Long
k = Target.Column
r = Target.Row
If Cells(1, k) = "P" Then
If Cells(r, k) = "x" Then
Cells(r, 4) = "x"
Else
Cells(r, 4) = ""
End If
End If
End Sub

Message boxes really don't belong in UDFs (VBA functions meant to be used as spreadsheet functions).
Instead of the message box you could use code like:
If Len(FromTime) <> 5 Then
TimeValue = "Error! Use format TT:MM - From time is wrong:" & FromTime
Exit Function
Or perhaps:
If Len(FromTime) <> 5 Then
TimeValue = CVErr(xlErrValue)
Exit Function
This later will cause #VALUE! to display in the cell. Include enough documentation in your spreadsheet so that users can interpret such error values.

Related

Arithmetic operation resulted in an overflow - Vb.Net

Hi I am getting the following error when computing GMT Time using nanoseconds as a long.
System.OverflowException: 'Arithmetic operation resulted in an overflow.'
Is there another data type that would work better with big values?
Private Sub gmtime(ByVal iSeconds As Object, ByVal iNanoseconds As Long, ByRef Timestamp As String)
Dim time As Object
Dim islpyr, lpcnt As Long
Dim t As Object
Dim i As Object
Dim ystart As Long
Dim y As Long
Dim sph As Object 'seconds per hour
Dim spd As Object 'seconds per day
Dim spy As Object 'seconds per year
Dim tm_sec As Long
Dim tm_min As Long
Dim tm_hour As Long
Dim tm_mday As Long
Dim tm_mon As Long
Dim tm_year As Long
Dim tm_wday As Long
Dim tm_yday As Long
Dim tm_isdst As Long
Dim mons(11) As Long
Dim temp As Object
Dim iMicroSeconds As Long
Dim iZeroCount As Long
Dim strZero As String
Dim strMicro As String
Dim iMicroData As Long
mons(0) = 31
mons(1) = 28
mons(2) = 31
mons(3) = 30
mons(4) = 31
mons(5) = 30
mons(6) = 31
mons(7) = 31
mons(8) = 30
mons(9) = 31
mons(10) = 30
mons(11) = 31
sph = CDec(60 * 60)
spd = CDec(24 * sph)
spy = CDec(365 * spd + 6 * sph) 'a year is about 365.25 days
tm_isdst = 0
time = CDec(iSeconds)
If time < 0 Then
time = time * (-1)
End If
i = CDec(time)
i = Fix(i / spd) Mod 7 + 4
While i >= 7
i = i - 7
End While
tm_wday = i
temp = Fix(time / spd)
temp = temp * spd
i = time - temp
tm_hour = Fix(i / sph) Mod 24
tm_min = Fix(i / 60) Mod 60
tm_sec = i Mod 60
y = Fix(time / spy)
y = y + 370
time = Fix(time / spd)
Do
islpyr = 0
If ((y Mod 4) = 0) And (((y Mod 100) <> 0) Or ((y Mod 400) = 0)) Then
islpyr = 1
End If
lpcnt = Fix(y / 4)
lpcnt = lpcnt - Fix(y / 100)
lpcnt = lpcnt + Fix(y / 400)
lpcnt = lpcnt - 89
ystart = (y - 370) * 365 + lpcnt
If ystart > time Then
y = y - 1
End If
Loop While ystart > time
time = time - ystart
If time = 365 Then
time = 0
y = y + 1
End If
If islpyr Then
time = time + 1
End If
tm_yday = time
time = time + 1
For i = 0 To 10
t = mons(i)
If (i = 1) And (islpyr = 1) Then
t = t + 1
End If
If time <= t Then
Exit For
End If
time = time - t
Next i
tm_year = y - 300 + 1900
tm_mon = i + 1
tm_mday = time
strZero = "."
iZeroCount = 6
iMicroSeconds = Fix(iNanoseconds / 1000)
iMicroData = iMicroSeconds
While iMicroSeconds <> 0
iMicroSeconds = Fix(iMicroSeconds / 10)
If (iMicroData Mod 10) = 0 Then
iMicroData = iMicroSeconds
End If
If iZeroCount <> 0 Then
iZeroCount = iZeroCount - 1
End If
End While
For i = 1 To iZeroCount
strZero = strZero + "0"
Next i
If Fix(iNanoseconds / 1000) <> 0 Then
strMicro = strZero + CStr(Fix(iNanoseconds / 1000))
Else
strMicro = strZero
End If
Timestamp = CStr(tm_year) + "-" + CStr(tm_mon) + "-" + CStr(tm_mday) + " " + CStr(tm_hour) + ":" + CStr(tm_min) + ":" + CStr(tm_sec) + strMicro
End Sub
It wouldn't let me add the code as the post is mostly code. The nanoseconds values are coming from a waveform file and this function is used to process it into GMT time.
The function is called on a loop for each line of the file and returns this error mid-way through the loop.
The value is '1.5518651852110167E+270' when it hits the error
I'm sorry but there's no way to put a 10^270 number inside ANY variable.
The biggest variable for numbers is Long that holds:
signed 64-bit (8-byte) integers ranging in value from
-9,223,372,036,854,775,808 through 9,223,372,036,854,775,807
(9.2...E+18).
From Long DataType
I sueggest you to avoiding counting time in nanoseconds instead use seconds, minutes, or even days if your TimeSpan is too big.
Counting time in nanoseconds is pointless.
Remarks
If you couldn't avoid using nanoseconds because your file is in nanoseconds your only option is to convert you nanoseconds value in a DateTime format on every line and hope that the value will be shorter than 9.2E+18
Otherwise you could use a BigInteger and use it to calculate a DateTime for every line of your file.
Just for the curiosity: You would need a 896 bytes unsigned DataType to store a 1.5*10^270 inside it.

Excel VBA: "Next Without For" Error

I am getting the "next without for" error. I checked other questions on this and looked for any open if statements or loops in my code, but could find none. I'm need an extra set of eyes to catch my error here.
I am trying to loop through this code and advance the torque value 3 times each times it gets to the 30th i.
'This is Holzer's method for finding the torsional natural frequency
Option Explicit
Sub TorsionalVibrationAnalysis_()
Dim n As Integer 'position along stucture
Dim m As Integer
Dim i As Long 'frequency to be used
Dim j As Variant 'moment of inertia
Dim k As Variant 'stiffness
Dim theta As Long 'angular displacement
Dim torque As ListRow 'torque
Dim lambda As Long 'ListRow 'omega^2
Dim w As Variant
Dim s As Long
'equations relating the displacement and torque
n = 1
Set j = Range("d2:f2").Value 'Range("d2:f2").Value
Set k = Range("d3:f3").Value
'initial value
Set w = Range("B1:B30").Value
For i = 1 To 30
'start at 40 and increment frequency by 20
w = 40 + (i - 1) * 20
lambda = w ^ 2
theta = 1
s = 1
Do While i = 30 & s <= 3
torque = lambda * j(1, s)
s = s + 1
End
m = n + 1
theta = theta - torque(i, n) / k(n)
torque(i, m) = torque(i, n) + lambda * j(m) * theta
If m = 4 & i < 30 Then
w(i) = 40 + (i - 1) * 20
lambda = w(i) ^ 2
ElseIf m = 4 & i >= 30 Then
Cells([d], [5+i]).display (i)
Cells([e], [5+i]).display (theta)
Cells([f], [5+i]).display (torque)
Else
End If
If m <> 4 Then
n = n + 1
End If
Next i
End Sub
You are trying to terminate your While with an End instead of Loop
Try changing your End to Loop in your Do While loop. I think you are terming the loop when you hit that End
Proper indentation makes the problem rather apparent.
You have:
For i = 1 To 30
'...
Do While i = 30 & s <= 3
'...
End
'...
If m = 4 & i < 30 Then
'...
ElseIf m = 4 & i >= 30 Then
'...
Else
End If
If m <> 4 Then
'...
End If
Next i
But run it through Rubberduck's Smart Indenter and you get:
For i = 1 To 30
'...
Do While i = 30 & s <= 3
'...
End
'...
If m = 4 & i < 30 Then
'...
ElseIf m = 4 & i >= 30 Then
'...
Else
End If
If m <> 4 Then
'...
End If
Next i
End Sub
Notice how the End other answers are pointing out, is clearly not delimiting the Do While loop.
The Next i is inside the Do While block, which isn't terminated - when the VBA compiler encounters that Next i, it doesn't know how it could possibly relate to any previously encountered For statement, and thus issues a "Next without For" compile error.
Use an indenter.

Runtime Error 13 : Type mismatch

This is my first time coding from scratch and a very dumb question indeed.
Why do i keep getting this error?
Runtime Error '13' : Type mismatch
My value in B1 is an integer
Private Sub Workbook_Open()
xdate = Worksheets("sheet1").Range("A1")
lsdate = DateAdd("d", -7, Date)
'MsgBox lsdate
If Day(lsdate) > Day(xdate) Then
Worksheets("sheet1").Range ("B1") * 1 = result
Else
Worksheets("sheet1").Range ("B1") * 1.07 = result
End If
Range("c1").Value = result
End Sub
I have further edit my code to the following but not able to get the condition to work
'To create the following condition
'If less than 7 days interest = 0%
'if 8 to 30 days interest = 7%
'if more than 31 days interest = 9%
Sub Workbook_Open()
For i = 1 To 3 'Rows.Count
xdate = Cells(i, 1)
'MsgBox Cells(i, 1)
nulldate = DateAdd("d", -7, Date)
irate7late = DateAdd("d", -8, Date)
irate7early = DateAdd("d", -30, Date)
If Day(nulldate) < Day(xdate) Then
result = Cells(i, 2) * 1
ElseIf Day(irate7early) <= Day(xdate) And Day(xdate) <= Day(irate7late) Then
'30/9/2015 20/10/2015 20/10/2015 22/10/2015
result = Cells(i, 2) * 1.07
ElseIf Day(irate7early) > Day(xdate) Then
result = Cells(i, 2) * 1.09
End If
Cells(i, 3).Value = result
Next i
End Sub
You seem pretty new at programming, so I'll explain plainly :
When you are trying to assign a value to a variable in almost every language, you use :
variable = value
So you can do a lot of operations on the value, which is on the right of the equals =.
BUT you canNOT do operations on the left of the equals = when you simply assigning a value to a variable. You can do almost any operations when you are testing 2 variables but you'll have a keyword like If or While at the start of the line of code.
So the issue with your code is that you reversed the order of the value and the variable and tried to do value * 1 = variable
Here is your corrected code (I indented it so that it can be read easily) :
Private Sub Workbook_Open()
xdate = Worksheets("sheet1").Range("A1")
lsdate = DateAdd("d", -7, Date)
'MsgBox lsdate
If Day(lsdate) > Day(xdate) Then
result = Worksheets("sheet1").Range ("B1") * 1
Else
result = Worksheets("sheet1").Range ("B1") * 1.07
End If
Sheets("Sheet_name").Range("c1").Value = result
End Sub
And you should always reference the sheet you are working with, because previously, your code didn't specify on which sheet the C1 was supposed to be.
So here, just change Sheet_name to whatever the name of your sheet is!
variables need to get the values from sheet. You are trying opposite way which is why you getting error.
Private Sub Workbook_Open()
xdate = Worksheets("sheet1").Range("A1")
lsdate = DateAdd("d", -7, Date)
'MsgBox lsdate
If Day(lsdate) > Day(xdate) Then
result = Worksheets("sheet1").Range("B1") * 1
Else
result = Worksheets("sheet1").Range("B1") * 1.07
End If
Range("c1").Value = result
End Sub
Sub test1()
Dim var1 As Variant
' If you need to get values from the range("D1") Then use the below code
var1 = Worksheets("sheet1").Range("D1").Value
End Sub

Connect Four Horizontal winner

I'm creating a connect four game and I'm having some trouble with the horizontal loop. The loop below works and it's for a vertical win. I have a two labels for each row and two labels for each column one for the color blue and one for the color red. When I add in my other labels I cant seem to find where I take the step-1 in order to change labels and go upwards with the next label. I have also tried adding a whole new loop below that just dedicated to the horizontal winnings.
For i = 5 To 0 Step -1`
If board(i, 0) = 0 Then
board(i, 0) = pturn
If pturn = 1 Then
Labelboard(i, 0).BackColor = Color.Red
CounterB = 0
lblcounterBlue.Text = "Matches = " & CounterB
CounterR = CounterR + 1
lblCounterRed.Text = "Matches = " & CounterR
ElseIf pturn = 2 Then
Labelboard(i, 0).BackColor = Color.Blue
CounterR = 0
lblCounterRed.Text = "Matches = " & CounterR
CounterB = CounterB + 1
lblcounterBlue.Text = "Matches = " & CounterB
End If
pturn = pturn + 1
If pturn = 3 Then pturn = 1
If CounterR = 4 Then
MsgBox("Game Over")
End If
If CounterB = 4 Then
MsgBox("Game Over")
End If
Exit Sub
End If
Next
I don't quite understand your setup, but hopefully this will get you close enough for you to get things working. I'm having to make a few assumptions, but I've tried to declare a constant each time I have to make the code more readable and easier for you to adapt to what you've already written.
What I've written is a function that lets you know if a specific space is part of winning streak. It assumes board() is public. If pturn is also public, you could make this even more efficient as long as you call it every turn, as noted in the comments. If you know which space was the last one played, you can maximize efficiency by only calling the function for that space (assuming you call it at the end of every player turn). If you don't know which space was played last, you can loop through every space in board() and test each one.
Function winner(rowNum As Integer, colNum As Integer) As Integer
'Returns 0 if space does not create a win, or the winning player number if it does
'Change to winner(...) As Boolean <--To only test current player
Dim minRow As Integer = LBound(board, 0)
Dim maxRow As Integer = UBound(board, 0)
Dim minColumn As Integer = LBound(board, 1)
Dim maxColumn As Integer = UBound(board, 1)
'These are the values I assume are in board()
'(I don't actually use them in the code)
Const emptySpace As Integer = 0
Const red As Integer = 1
Const blue As Integer = 2
Dim player As Integer
Dim streak As Integer
Dim r As Integer, c As Integer 'loop placeholders
Dim v As Integer, h As Integer 'control search direction
For v = 0 To 1
For h = -1 To 1
If v = 1 Or h = 1 Then
'These loops and test check each direction (vertical, horizontal and
'both diagonals) for a win exactly once.
player = board(rowNum, colNum)
If player > 0 Then 'If player = pturn <-- to only check current player
streak = 1
'check positive direction
r = rowNum + h
c = colNum + v
Do While r >= minRow And r <= maxRow And c >= minColumn And c <= maxColumn
If board(r, c) = player Then
streak = streak + 1
If streak = 4 Then
Return player 'True <--If testing only current player
Else
r = r + h
c = c + v
End If
Else
Exit Do
End If
Loop
'check negative direction
r = rowNum - h
c = colNum - v
Do While r >= minRow And r <= maxRow And c >= minColumn And c <= maxColumn
If board(r, c) = player Then
streak = streak + 1
If streak = 4 Then
Return player 'True <--If testing only current player
Else
r = r - h
c = c - v
End If
Else
Exit Do
End If
Loop
End If
End If
Next h
Next v
Return 0 'Function has completed and no winner was found
'Return False <-- If only testing current player
End Function

Simulation runs fine # 10k cycles, but gets error 13 (type mismatch) # 100k cycles

First off, here's my code:
Sub SimulatePortfolio()
Dim lambda As Double
Dim num As Integer
Dim cycles As Long
Column = 12
q = 1.5
lambda = 0.05
cycles = 100000
Dim data(1 To 100000, 1 To 10) As Integer
Dim values(1 To 10) As Double
For i = 1 To 10
values(i) = 0
Next i
temp = lambda
For i = 1 To cycles
lambda = temp
num = 10
t = 0
Dim temps(1 To 10) As Integer
For k = 1 To 10
temps(k) = 1000
Next k
Do While (t < 10 And num > 0)
t = t + tsim(lambda, num)
For j = 1 To 10
If (j > t) Then
temps(j) = temps(j) - 50
End If
Next j
num = num - 1
If (num <= 0) Then
Exit Do
End If
lambda = lambda * q
Loop
For l = 1 To 10
values(l) = values(l) + temps(l)
data(i, l) = temps(l)
Next l
Next i
For i = 1 To 10
Cells(i + 1, Column) = values(i) / cycles
'Problem occurs on this line:
Cells(i + 1, Column + 1).Value = Application.WorksheetFunction.Var(Application.WorksheetFunction.Index(data, i, 0))
Next i
End Sub
Function tsim(lambda As Double, num As Integer) As Double
Dim v As Double
Dim min As Double
Randomize
min = (-1 / lambda) * Log(Rnd)
For i = 1 To (num - 1)
Randomize
v = (-1 / lambda) * Log(Rnd)
If (min > v) Then
min = v
End If
Next i
tsim = min
End Function
When I set the value for cycles to 10000, it runs fine without a hitch. When I go to 100000 cycles, it gets an Error 13 at the indicated line of code.
Having been aware that Application.Tranpose is limited to 65536 rows with variants (throwing the same error) I tested the same issue with Index
It appears that Application.WorksheetFunction.Index also has a limit of 65536 rows when working with variants - but standard ranges are fine
So you will need to either need to dump data to a range and work on the range with Index, or work with two arrays
Sub Test()
Dim Y
Dim Z
'works in xl07/10
Debug.Print Application.WorksheetFunction.Index(Range("A1:A100000"), 1, 1)
Y = Range("A1:A65536")
`works
Debug.Print Application.WorksheetFunction.Index(Y, 1, 1)
'fails in xl07/10
Z = Range("A1:A65537")
Debug.Print Application.WorksheetFunction.Index(Z, 1, 1)
End Sub