I'll start off by saying i have jut started teaching myself VBA about a week ago, so I may not be asking the right question, but...
I am attempting to write a loop in Word VBA that will increment a number calculated partially from text retrieved from bookmarks. I want it to round up to the nearest .05, so .87 becomes .90 and .21 becomes .25.
The module that I have written follows:
A = ActiveDocument.Bookmarks("SRebateIncome").Range.Text
B = ActiveDocument.Bookmarks("RebateDefault").Range.Text
C = ((A - 6000) * 0.15)
D = B - C
E = B + D
F = (18200 + ((445 + E) / 0.19)) + 1
G = (0.19 * 18200) + 445 + E + (37000 * (0.015 + 0.325 - 0.19))
H = (G / (0.015 + 0.325)) + 1
I = ActiveDocument.Bookmarks("TRebateIncome").Range.Text
If F < 37000 = True Then
J = (0.125 * (I - F))
Else
J = (0.125 * (I - H))
End If
K = E - J
K = Format(Round(K, 2), "###,##0.00")
'round K up to the nearest .00 or .05
If K <> "###,###.#0" = False or K <> "###,###.#5") = False Then
Do
K = K + 0.01
Loop Until K = "###,###.#0" = True or K <> "###,###.#5") = True
End If
Set RebateOutput = ActiveDocument.Bookmarks("RebateOutput").Range
RebateOutput.Text = K
Now assuming that the value input for bookmarks "SRebateIncome", "RebateDefault" and "TRebateIncome" are 10175, 1602 and 43046 respectively, I expected the output to be 1460.80, but instead "K" is returned as 1460.78.
At this stage I don't know anything about using Excel within word (except copy/paste a spreadsheet into a document and I don't want to do that with this).
Any help would be appreciated
Thanks!
You can do it with an excel object and the Ceiling function
Option Explicit
Sub RoundText()
Dim dblSRebateIncome As Double
Dim dblRebateDefault As Double
Dim dblTRebateIncome As Double
Dim dblFinal As Double
Dim rngOutput As Range
Dim oExcel As Object
' Load the variables
Set oExcel = CreateObject("Excel.Application")
Set rngOutput = ActiveDocument.Bookmarks("RebateOutput").Range
dblSRebateIncome = CDbl(ActiveDocument.Bookmarks("SRebateIncome").Range.Text)
dblRebateDefault = CDbl(ActiveDocument.Bookmarks("RebateDefault").Range.Text)
dblSRebateIncome = CDbl(ActiveDocument.Bookmarks("TRebateIncome").Range.Text)
dblFinal = GetCalculatedValue(dblSRebateIncome, dblRebateDefault, dblTRebateIncome)
dblFinal = oExcel.worksheetfunction.Ceiling(dblFinal, 0.05)
rngOutput.Text = Format$(dblFinal, "###,##0.00")
End Sub
Function GetCalculatedValue(ByVal dblSIncome As Double, _
ByVal dblDefault As Double, _
ByVal dblTIncome) As Double
' Declare all the intermediate variables.
Dim c As Double, d As Double, e As Double
Dim f As Double, g As Double, h As Double
Dim j As Double, ret As Double
' Perform the complicated calculation
c = ((dblSIncome - 6000) * 0.15)
d = dblDefault - c
e = dblDefault + d
f = (18200 + ((445 + e) / 0.19)) + 1
g = (0.19 * 18200) + 445 + e + (37000 * (0.015 + 0.325 - 0.19))
h = (g / (0.015 + 0.325)) + 1
If f < 37000 Then
j = (0.125 * (dblTIncome - f))
Else
j = (0.125 * (dblTIncome - h))
End If
ret = e - j
' Return the value of the fucntion
GetCalculatedValue = ret
End Function
Hope this helps. :)
Dim x As Double
x = 1.111 'E.g.
Debug.Print Round(x * 20, 0)/20 '>> 1.10
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
So I have a "main" function (SolveSixODES) that calls a secondary function (AllODEs). And when it does this, the x value in the main function gets modified. I don't understand how this can be possible, seeing as it is not a global variable.
Here is the code, my inputs I used are as follows:
x=0, xmax=3, y=0-6, h=0.1, error=0.1
Public Function SolveSixODE(x As Double, xmax As Double, Y As Range, h As Double, error As Double) 'Weird bug: You must leave the first y4 value blank
Dim i As Integer, k(7, 7) As Double, j As Integer, m As Integer 'k(Order #, equation #)
Dim Y5(7) As Double, Y4(7) As Double, Y4Old(7) As Double
Dim delta0(7) As Double, delta1(7) As Double, delRatio(7) As Double, Rmin As Double
For i = 1 To 6 'Moving the input data so it can acutally be used
Y4(i) = Y(i)
Next i
While x < xmax
If x + h < xmax Then
x = x + h
Else
h = xmax - x
x = xmax
End If
For j = 1 To 6 'j is the order i is equation number
For i = 1 To 6 'Calculating all of the k(1) values for eq 1 to 6
k(j, i) = AllODES(x, Y4, i, j, k, h) '!!!!!SOME HOW THIS LOOP MAKES X negative...!!!!!!!
Next i
Next j
For i = 1 To 6
Y4Old(i) = Y4(i) 'Saving old y4 value to calc delta0
Y4(i) = Y4(i) + h * (k(1, i) * (37 / 378) + k(3, i) * (250 / 621) + k(4, i) * (125 / 594) + k(6, i) * (512 / 1771))
Y5(i) = Y4(i) + h * (k(1, i) * (2825 / 27648) + k(3, i) * (18575 / 48384) + k(4, i) * (13525 / 55296) + k(5, i) * (277 / 14336) + k(6, i) * (0.25))
delta0(i) = error * (Abs(Y4Old(i)) + Abs(h * AllODES(x, Y4Old, i, 1, k, h))) 'First order because we don't want to use the k vals
delta1(i) = Abs(Y5(i) - Y4(i))
delRatio(i) = Abs(delta0(i) / delta1(i)) 'Ratio of errors
Next i
Rmin = delRatio(1)
For i = 2 To 6
If delRatio(i) < Rmin Then
Rmin = delRatio(i) 'Determine the smallest error ratio
End If
Next i
If Rmin < 1 Then 'If this is true then the step size was too big must repeat step
x = x - h 'Set x and y's back to previous values
For i = 1 To 6
Y4(i) = Y4Old(i)
Next i
h = 0.9 * h * Rmin ^ 0.25 'adjust h value; 0.9 is a safety factor
Else
h = 0.9 * h * Rmin ^ 0.2 'Otherwise, we march on
End If
m = m + 1
Wend
SolveSixODE = Y4
End Function
Public Function AllODES(x As Double, Y() As Double, EqNumber As Integer, order As Integer, k() As Double, h As Double) As Double
Dim conc(7) As Double, i As Integer, j As Integer
If order = 1 Then
x = x - h
For i = 1 To 6 'Movin the data so I can use it
conc(i) = Y(i) 'also adjusting the x and y values for RK4 (Cash Karp values)
Next i
ElseIf order = 2 Then
x = x - h + h * 0.2
For i = 1 To 6
conc(i) = Y(i) + h * k(1, i) * 0.2
Next i
ElseIf order = 3 Then
x = x - h + 0.3 * h
For i = 1 To 6
conc(i) = Y(i) + h * (0.075 * k(1, i) + 0.225 * k(2, i))
Next i
ElseIf order = 4 Then
x = x - h + 0.6 * h
For i = 1 To 6
conc(i) = Y(i) + h * (0.3 * k(1, i) - 0.9 * k(2, i) + 1.2 * k(3, i))
Next i
ElseIf order = 5 Then
x = x - h + h
For i = 1 To 6
conc(i) = Y(i) + h * ((-11 / 54) * k(1, i) + 2.5 * k(2, i) - (70 / 27) * k(3, i) + (35 / 27) * k(4, i))
Next i
ElseIf order = 6 Then
x = x - h + 0.875 * h
For i = 1 To 6
conc(i) = Y(i) + h * ((1631 / 55296) * k(1, i) + (175 / 512) * k(2, i) + (575 / 13824) * k(3, i) + (44275 / (110592) * k(4, i) + (253 / 4096) * k(5, i)))
Next i
Else
MsgBox ("error")
End If
If EqNumber = 1 Then 'These are the actual equations
AllODES = x + Y(1)
ElseIf EqNumber = 2 Then
AllODES = x
ElseIf EqNumber = 3 Then
AllODES = Y(3)
ElseIf EqNumber = 4 Then
AllODES = 2 * x
ElseIf EqNumber = 5 Then
AllODES = 2 * Y(2)
ElseIf EqNumber = 6 Then
AllODES = 3 * x
Else
MsgBox ("You entered an Eq Number that was dumb")
End If
End Function
It's possible that it is something really trivial that I missed but this seems to contradict my knowledge of how variables work. So if you understand how the function is able to manipulate a variable from another function in this case, I would appreciate any advice and/or explanation!
Thanks in advance!
the x value in the main function gets modified. I don't understand how this can be possible, seeing as it is not a global variable
This is normal because you are passing x by reference to the function AllODES and you do change it there. When the keyword ByVal is not explicitly specified in the function/sub prototype, the default passing mechanism is ByRef, that is, by reference.
Public Function AllODES(x As Double, ...
means
Public Function AllODES(ByRef x As Double, ....
We observe that x is manipulated in this function, so the change will appear in the caller. If you want that the change of x does not report back in the caller's scope, pass x by value:
Public Function AllODES(ByVal x As Double, ....
' ^^^^^
Only in this case the x of the caller and the x of the callee will be two different variables.
My vba code keeps returning a value of 0 when I know the roots of my function are not 0.
It's pretty simple code but I can't seem to debug it. Any idea where this error might be coming from??
Option Explicit
Public Function Bisect(ByVal xlow As Double, ByVal xhigh As Double) As Double
Dim i As Integer
Dim xmid As Double
xmid = (xlow + xhigh) / 2
For i = 1 To 100
If f(xlow) * f(xmid) < 0 Then
xhigh = xmid
xmid = (xlow + xhigh) / 2
Else
xlow = xmid
xmid = (xlow + xhigh) / 2
End If
Next i
Bisect = xmid
End Function
Function f(ByVal x As Double, Optional ByRef inputArray As Range) As Variant
Dim ca0 As Double
Dim v0 As Double
Dim k As Double
Dim e As Double
Dim ac As Double
Dim L As Double
inputArray(2, 2) = ca0
inputArray(3, 2) = v0
inputArray(4, 2) = k
inputArray(5, 2) = e
inputArray(6, 2) = ac
inputArray(7, 2) = L
f(x) = (v0 / (k * ca0 * ac)) * ((2 * e * (1 + e) * Log(1 - x)) + (e ^ 2 * x) + (((1 + e) ^ 2 * x) / (1 - x))) - L
End Function
' i Think you want to take those constant values from cells presentin the sheet
Function f(ByVal x As Double) As Variant
Dim inputArray As Range
Dim ca0 As Double
Dim v0 As Double
Dim k As Double
Dim e As Double
Dim ac As Double
Dim L As Double
' i Think you want to take values from cells in the sheet
ca0 = ActiveSheet.Cells(2, 2).Value
v0 = ActiveSheet.Cells(3, 2).Value
k = ActiveSheet.Cells(4, 2).Value
e = ActiveSheet.Cells(5, 2).Value
ac = ActiveSheet.Cells(6, 2).Value
L = ActiveSheet.Cells(7, 2).Value
Could it be that you try to assign the inputarray with empty variables?
In my mind it should be:
ca0 = inputArray(2, 2)
v0 = inputArray(3, 2)
And so on.
I'm guessing
f(x) = (v0 / (k * ca0 * ac)) * ((2 * e * (1 + e) * Log(1 - x)) + (e ^ 2 * x) + (((1 + e) ^ 2 * x) / (1 - x))) - L
Should be
f = (v0 / (k * ca0 * ac)) * ((2 * e * (1 + e) * Log(1 - x)) + (e ^ 2 * x) + (((1 + e) ^ 2 * x) / (1 - x))) - L
I have issue with an Excel worksheet that contains the formula:
=Spline($D$9:$D$34,$J$9:$J$34,$D43)
Sheet works fine until I open this sheet on network drive and save it on local drive. Then this formula throws #NAME? error. Strange is, that error is gone when I click on line with formula to edit it and press enter (nothing changes in formula).
Have someone met similar issue?
I just found another information. Formula spline is defined in VBA module, not internal in Excel. It looks like. But issue is still here.
Function spline(periodcol As Range, ratecol As Range, x As Range)
Dim period_count As Integer
Dim rate_count As Integer
period_count = periodcol.Rows.Count
rate_count = ratecol.Rows.Count
If period_count <> rate_count Then
spline = "Error: Range count does not match"
GoTo endnow
End If
ReDim xin(period_count) As Single
ReDim yin(period_count) As Single
Dim c As Integer
For c = 1 To period_count
xin(c) = periodcol(c)
yin(c) = ratecol(c)
Next c
Dim n As Integer
Dim i, k As Integer
Dim p, qn, sig, un As Single
ReDim u(period_count - 1) As Single
ReDim yt(period_count) As Single
n = period_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
Dim klo, khi As Integer
Dim h, b, a As Single
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
spline = y
endnow:
End Function
Try to add:
Application.Volatile
to your VBA code. Add this just below the Function statement to force a renewed calculation as soon as anything changes.
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