=IF((effDate)-curDate>0,0,IF(curDate-(effDate)+1>nDays,0,nSpend/4))+IF((effDate+365/4*1)-curDate>0,0,IF(curDate-(effDate+365/$4*1)+1>nDays,0,nSpend/4))+IF((effDate+365/4*2)-curDate>0,0,IF(curDate-(effDate+365/4*2)+1>nDays,0,nSpend/4))+IF((effDate+365/4*3)-curDate>0,0,IF(curDate-(effDate+365/4*3)+1>nDays,0,nSpend/4))
effDate: 1/1/2017 (as value)
curDate: 1/31/2017 (as value)
nSpend: 1600
nDays: 60
Correct answer: 400
Above is a long formula I'm trying to covert to VBA code. The way I've been trying to do it is long and I tried breaking it up into smaller functions, but it's not giving me the right answer. My VBA skills are very beginner so I'm not sure what else to try. I keep getting the wrong answer or no answer at all.
This is what I've been trying:
If effdate - curdate > 0 Then
val1 = 0
Exit Function
End If
If curdate - effDate + 1 > nDays Then
val1 = 0
Else
val1 = nSpend / 4
End If
If (effDate + (365 / 4)) - curdate > 0 Then
val2 = 0
Exit Function
End If
If curdate - (effDate + (365 / 4)) + 1 > nDays Then
val2 = 0
Else
val2 = nSpend / 4
End If
If effDate + (365 / (4 * 2)) - curdate > 0 Then
val3 = 0
Exit Function
End If
If curdate - (effDate + (365 / (4 * 2))) + 1 > nDays Then
val3 = 0
Else
val3 = nSpend / 4
End If
If effDate + (365 / (4 * 3)) - curdate > 0 Then
val4 = 0
Exit Function
End If
If curdate - (effDate + (365 / (4 * 3))) + 1 > nDays Then
val4 = 0
Else
val4 = nSpend / 4
End If
End If
APFcst = val1 + val2 + val3 + val4
End Function
I dimmed everything correctly, it's the actual conversion that I have problems with.
I would appreciate the help! This is also a huge learning stretch for me since I just started learning VBA coding.
Thank you!
If you know the formula then you can use Evaluate() to achieve what you want.
Sub Sample()
Dim f1, f2, f3, f4
f1 = "=IF((effDate)-curDate>0,0,IF(curDate-(effDate)+1>nDays,0,nSpend/4))"
f2 = "=IF((effDate+365/4*1)-curDate>0,0,IF(curDate-(effDate+365/4*1)+1>nDays,0,nSpend/4))"
f3 = "=IF((effDate+365/4*2)-curDate>0,0,IF(curDate-(effDate+365/4*2)+1>nDays,0,nSpend/4))"
f4 = "=IF((effDate+365/4*3)-curDate>0,0,IF(curDate-(effDate+365/4*3)+1>nDays,0,nSpend/4))"
'~~> Change Sheet1 to the relevant sheet code name
Debug.Print Sheet1.Evaluate(f1) + Sheet1.Evaluate(f2) + Sheet1.Evaluate(f3) + Sheet1.Evaluate(f4)
End Sub
DateAdd ( interval, number, date )
You should investigate this and apply it towards what youre trying to do :)
https://www.techonthenet.com/excel/formulas/dateadd.php
I was intrigued by this to see why it wasn't working, I've rewrote the if > else > else logic to an if or > else but it achieves the same thing. Like Doug Coats' answer says, you can use DateAdd to work with subtraction/adding dates together. I've just converted the date strings to double:
Private Sub CommandButton1_Click()
Dim x As Date: Dim y As Date
Dim effDate As Double
Dim curDate As Double
Dim nSpend As Double
Dim nDays As Double
x = "1/1/17"
y = "31/1/17"
effDate = CDbl(x)
curDate = CDbl(y)
nSpend = 1600
nDays = 60
If (effDate - curDate > 0) Or (curDate - effDate + 1 > nDays) Then
val1 = 0
Else
val1 = nSpend / 4
End If
If ((effDate + (365 / 4)) - curDate > 0) Or (curDate - (effDate + (365 / 4)) + 1 > nDays) Then
val2 = 0
Else
val2 = nSpend / 4
End If
If (effDate + (365 / (4 * 2)) - curDate > 0) Or (curDate - (effDate + (365 / (4 * 2))) + 1 > nDays) Then
val3 = 0
Else
val3 = nSpend / 4
End If
If (effDate + (365 / (4 * 3)) - curDate > 0) Or (curDate - (effDate + (365 / (4 * 3))) + 1 > nDays) Then
val4 = 0
Else
val4 = nSpend / 4
End If
MsgBox (val1 + val2 + val3 + val4)
End Sub
Related
I'm trying to write a recursive function so that it calculates the sum of the products of the combinations of values in a dynamic array. Right now I've been trying to make it work for a simpler case, but I really don't quite understand the structure I should follow for a recursive function. In this case there's supposed to be the sum of 28 two factor products, resulting 1.4
Sub SuPC()
Dim k As Long
Dim s As Long
Dim i As Long
Dim j As Long
k = 8
s = 2
HSum i, j, s, k
End Sub
Function HSum(i As Long, j As Long, s, k) As Double
Dim P As Variant
Dim z() As Double
Dim Tot As Double
ReDim z(0 To (k * s) - 1)
P = Array(1 / 2, 1 / 3, 1 / 4, 1 / 5, 1 / 6, 1 / 7, 1 / 8, 1 / 9)
If i <= k Then
HSum i + 1, j, s, k
If j <= s Then
HSum i, j + 1, s, k
If z(i) = 0 Then z(i) = 1
z(i) = P(j) * z(i)
End If
Tot = z(i) + Tot
End If
Range("J11") = Tot
End Function
If s and k were low fixated values, I could use For loops but the point is for them to be variable.
You should try to use tail recursion as this is just a sum of the products,
see here an example for tail recursion factoring.
Public Function fact_tail(n As Double) As Double
'Tail Recursion
'fact 4 = 4 * fact 3
' = 4* 3 * fact 2
' = 4* 3 * 2 * fact 1
' = 4* 3 * 2 * 1
'fact 4 = go(4, 1)
' = go((n - 1), (a * n))
' = go((4-1),(1*4))
' = go(3, 4)
' = go(3-1, 3*4)
' = go(2, 12)
' = go(2-1, 12*2)
' = go(1, 24)
' = 4* 3 * 2 * 1 = 24
fact_tail = go_fact(n, 1)
End Function
Private Function go_fact(n, a)
If n <= 1 Then
go_fact = a
Else
go_fact = go_fact((n - 1), (a * n))
End If
End Function
I don't understand why I cannot compare an array in VBA. I created an array that starts 0 1 2 3. I added a comparison due to subscript errors trying to compare 0 to 0 - 1 so it can only start comparisons at 1 and continue. Now I'm receiving a type Mismatch 13 and I can't figure out why the data type is different/not working. I'm guessing i in a for loop is not considered an int or something?
It fails at CoordinatesArray(i) = CoordinatesArray(i-1)
Code:
For i = 0 To NumLines - 1
coordx1 = (vLines(12 * i + 6))
coordy1 = (vLines(12 * i + 7))
coordz1 = (vLines(12 * i + 8))
CoordinatesArray(i) = Array(coordx1, coordy1, coordz1)
If i > 0 Then
If CoordinatesArray(i) = CoordinatesArray(i - 1) Then
coordx1 = (vLines(7))
You will need to compare each value in the jagged array separately:
For i = 0 To NumLines - 1
coordx1 = (vLines(12 * i + 6))
coordy1 = (vLines(12 * i + 7))
coordz1 = (vLines(12 * i + 8))
CoordinatesArray(i) = Array(coordx1, coordy1, coordz1)
If i > 0 Then
If CoordinatesArray(i)(1) = CoordinatesArray(i - 1)(1) And _
CoordinatesArray(i)(2) = CoordinatesArray(i - 1)(2) And _
CoordinatesArray(i)(3) = CoordinatesArray(i - 1)(3) Then
coordx1 = (vLines(7))
This is the formula in Excel that I'm trying to convert to VBA code:
=IFERROR(IF(effDate>curDate,0,IF((curDate-effDate+1)>nDays,nDays*(nSpend/365),((nSpend/365)*(curDate-effDate+1))-IF((curDate-effDate+1)-nDays>0,nSpend/365,0))),0)
For checking working purposes here are the values for each variable:
effDate: 1/1/17 (dimmed as value)
curDate: 3/31/17 (dimmed as value)
nDays: 60
nSpend: 1600
Correct answer: 263
I tried to make it work for two days now and I retyped in about a hundred different way and none of them work. The code may work for one cell but it doesn't calculate correctly for the others. Or it doesn't work at all. Here is one of the examples of what I made earlier (name of the function is APFcst):
If effDate > curDate then
APFcst = 0
Exit Function
End if
If (curDate - effDate + 1) > nDays then
APFcst = nDays * (nSpend / 365)
Else
val1 = (nSpend / 365) * (curDate - effDatea + 1)
end if
if (curDate - effDate + 1) - nDays > 0 then
val2 = nSpend / 365
else
val2 = 0
end if
APFcst = val1 - val2
Exit Function
End if
NOTE: everything is dimmed properly, the issue that I'm having is just translating the actual formula so it'll give me the correct answer.
Please help! I've been staring at this for so long that I might not see an obvious solution.
After noticing that the last IF check in your formula is redundant, here's a simplification of your equation:
Function xAPFcst(effDate, curDate, nSpend, nDays) As double
xAPFcst = IIf(effDate > curDate, 0, (nSpend / 365) * Application.Min(nDays, curDate - effDate + 1))
End function
Something like this, maybe possible to shorten it a touch using IIF's and perhaps, looking at using (nSpend / 365) a bit more effectively, i'll take a look again later. I've not properly tested as yet.
Function formula_test(dtCurrentDate As Date, dtEffectiveDate As Date, nDays As Long, nSpend As Double) As Double
On Error GoTo eHandle
If dtEffectiveDate > dtCurrentDate Then
formula_test = 0
Else
If ((dtCurrentDate - dtEffectiveDate) + 1) > nDays Then
formula_test = nDays * (nSpend / 365)
Else
formula_test = ((nSpend / 365) * (dtCurrentDate - dtEffectiveDate + 1))
If (dtCurrentDate - dtCurrentDate + 1) - nDays > 0 Then
formula_test = formula_test - nSpend / 365
End If
End If
End If
Exit Function
eHandle:
formula_test = 0
End Function
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.
I have a function that only call the spline function when something happens..in this case when a division is less than zero..the inputs for the function is the same that for the spline function(called CUBIC), the spline was tested and works well when I call it direct! someone can help me?...follows a party of the code
Function NDF6(T As Variant, dias As Variant, taxas As Variant)
If T <= dias(1) Then
NDF6 = taxas(1)
Exit Function
End If
If T >= dias(tam) Then
NDF6 = taxas(tam)
Exit Function
End If
For i = 1 To tam
If T <= dias(i) Then
If taxas(i) / taxas(i - 1) < 0 Then
Call CUBIC(T, dias, taxas)
Else
i0 = ((taxas(i - 1) * dias(i - 1)) / 360) + 1
i1 = ((taxas(i - 1) * dias(i - 1)) / 360) + 1
irel = i1 / i0
i2 = irel ^ ((T - dias(i - 1)) / (dias(i) - dias(i - 1)))
i2rel = i2 * i0
i2real = i2rel - 1
NDF6 = i2real * (360 / T)
End If
Public Function CUBIC(x As Variant, input_column As Variant, output_column As Variant)
The function returns a zero value when I call the cubic function. The inputs are a cell with a value with a value equivalent a day and two arrays(DUONOFF and ONOFF) equivalent a days and rates, I call the function like:
NDF6(512,DUONOFF,ONOFF)
follows the CUBIC function
Public Function CUBIC(x As Variant, input_column As Variant, output_column As Variant)
'Purpose: Given a data set consisting of a list of x values
' and y values, this function will smoothly interpolate
' a resulting output (y) value from a given input (x) value
' This counts how many points are in "input" and "output" set of data
Dim input_count As Integer
Dim output_count As Integer
input_count = input_column.Rows.Count
output_count = output_column.Rows.Count
Next check to be sure that "input" # points = "output" # points
If input_count <> output_count Then
CUBIC = "Something's messed up! The number of indeces number of output_columnues don't match!"
GoTo out
End If
ReDim xin(input_count) As Single
ReDim yin(input_count) As Single
Dim c As Integer
For c = 1 To input_count
xin(c) = input_column(c)
yin(c) = output_column(c)
Next c
values are populated
Dim N As Integer 'n=input_count
Dim i, k As Integer 'these are loop counting integers
Dim p, qn, sig, un As Single
ReDim u(input_count - 1) As Single
ReDim yt(input_count) As Single 'these are the 2nd deriv values
N = input_count
yt(1) = 0
u(1) = 0
For i = 2 To N - 1
sig = (xin(i) - xin(i - 1)) / (xin(i + 1) - xin(i - 1))
p = sig * yt(i - 1) + 2
yt(i) = (sig - 1) / p
u(i) = (yin(i + 1) - yin(i)) / (xin(i + 1) - xin(i)) - (yin(i) - yin(i - 1)) / (xin(i) - xin(i - _1))
u(i) = (6 * u(i) / (xin(i + 1) - xin(i - 1)) - sig * u(i - 1)) / p
Next i
qn = 0
un = 0
yt(N) = (un - qn * u(N - 1)) / (qn * yt(N - 1) + 1)
For k = N - 1 To 1 Step -1
yt(k) = yt(k) * yt(k + 1) + u(k)
Next k
now eval spline at one point
Dim klo, khi As Integer
Dim h, b, a As Single
first find correct interval
klo = 1
khi = N
Do
k = khi - klo
If xin(k) > x Then
khi = k
Else
klo = k
End If
k = khi - klo
Loop While k > 1
h = xin(khi) - xin(klo)
a = (xin(khi) - x) / h
b = (x - xin(klo)) / h
y = a * yin(klo) + b * yin(khi) + ((a ^ 3 - a) * yt(klo) + (b ^ 3 - b) * yt(khi)) * (h ^ 2) _/ 6
CUBIC = y
out:
End Function