It would be nice if someone could explain what causes function above return #value error.
Public Function papild(x)
Dim Sum As Double, A As Double, pi As Double,
Sum = 0.5 - (x - pi / 4)
A = -(x - pi / 4)
pi = Application.WorksheetFunction.pi()
Dim k As Integer, i As Integer
k = 2
i = 0
Do While Abs(A) > 0.0001
A = -A * 4 * A * A / (k + i) * (k + i + 1)
Sum = Sum + A
k = k + 1
i = i + 1
Loop
paplid = Sum
End Function
Function takes x value from MS Excel cell and it's equal = -1.5708 (=-PI()/2 #Formula Bar)
In lines 3 and 4 you work with variable pi before setting it in line 5...
Could there be some brackets missing in your formula. It basically says:
A = -4A^3 * (k+i+1)/(k+1)
This obviously drifts to +/- infinite so your loop cannot end.
Also there is a comma too much in the second line and a spelling error in the last line (paplid instead of papild).
Have you tried debugging the code?
When I run the code I get an overflow error # the 6th iteration of the while loop starting with x = -1.5708. Number gets to large to fit inside variable
.Other than that there are some minor things:
missing As Double
Public Function papild(x) As Double
and unnecessary comma at the end
Dim Sum As Double, A As Double, pi As Double,
Related
I'm trying to write a simple function in VBA that will test a real value and output a string result if it's a perfect cube. Here's my code:
Function PerfectCubeTest(x as Double)
If (x) ^ (1 / 3) = Int(x) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function
As you can see, I'm using a simple if statement to test if the cube root of a value is equal to its integer portion (i.e. no remainder). I tried testing the function with some perfect cubes (1, 8, 27, 64, 125), but it only works for the number 1. Any other value spits out the "Flawed" case. Any idea what's wrong here?
You are testing whether the cube is equal to the double supplied.
So for 8 you would be testing whether 2 = 8.
EDIT: Also found a floating point issue. To resolve we will round the decimals a little to try and overcome the issue.
Change to the following:
Function PerfectCubeTest(x As Double)
If Round((x) ^ (1 / 3), 10) = Round((x) ^ (1 / 3), 0) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function
Or (Thanks to Ron)
Function PerfectCubeTest(x As Double)
If CDec(x ^ (1 / 3)) = Int(CDec(x ^ (1 / 3))) Then
PerfectCubeTest = "Perfect"
Else
PerfectCubeTest = "Flawed"
End If
End Function
#ScottCraner correctly explains why you were getting incorrect results, but there are a couple other things to point out here. First, I'm assuming that you are taking a Double as input because the range of acceptable numbers is higher. However, by your implied definition of a perfect cube only numbers with an integer cube root (i.e. it would exclude 3.375) need to be evaluated. I'd just test for this up front to allow an early exit.
The next issue you run into is that 1 / 3 can't be represented exactly by a Double. Since you're raising to the inverse power to get your cube root you're also compounding the floating point error. There's a really easy way to avoid this - take the cube root, cube it, and see if it matches the input. You get around the rest of the floating point errors by going back to your definition of a perfect cube as an integer value - just round the cube root to both the next higher and next lower integer before you re-cube it:
Public Function IsPerfectCube(test As Double) As Boolean
'By your definition, no non-integer can be a perfect cube.
Dim rounded As Double
rounded = Fix(test)
If rounded <> test Then Exit Function
Dim cubeRoot As Double
cubeRoot = rounded ^ (1 / 3)
'Round both ways, then test the cube for equity.
If Fix(cubeRoot) ^ 3 = rounded Then
IsPerfectCube = True
ElseIf (Fix(cubeRoot) + 1) ^ 3 = rounded Then
IsPerfectCube = True
End If
End Function
This returned the correct result up to 1E+27 (1 billion cubed) when I tested it. I stopped going higher at that point because the test was taking so long to run and by that point you're probably outside of the range that you would reasonably need it to be accurate.
For fun, here is an implementation of a number-theory based method described here . It defines a Boolean-valued (rather than string-valued) function called PerfectCube() that tests if an integer input (represented as a Long) is a perfect cube. It first runs a quick test which throws away many numbers. If the quick test fails to classify it, it invokes a factoring-based method. Factor the number and check if the multiplicity of each prime factor is a multiple of 3. I could probably optimize this stage by not bothering to find the complete factorization when a bad factor is found, but I had a VBA factoring algorithm already lying around:
Function DigitalRoot(n As Long) As Long
'assumes that n >= 0
Dim sum As Long, digits As String, i As Long
If n < 10 Then
DigitalRoot = n
Exit Function
Else
digits = Trim(Str(n))
For i = 1 To Len(digits)
sum = sum + Mid(digits, i, 1)
Next i
DigitalRoot = DigitalRoot(sum)
End If
End Function
Sub HelperFactor(ByVal n As Long, ByVal p As Long, factors As Collection)
'Takes a passed collection and adds to it an array of the form
'(q,k) where q >= p is the smallest prime divisor of n
'p is assumed to be odd
'The function is called in such a way that
'the first divisor found is automatically prime
Dim q As Long, k As Long
q = p
Do While q <= Sqr(n)
If n Mod q = 0 Then
k = 1
Do While n Mod q ^ k = 0
k = k + 1
Loop
k = k - 1 'went 1 step too far
factors.Add Array(q, k)
n = n / q ^ k
If n > 1 Then HelperFactor n, q + 2, factors
Exit Sub
End If
q = q + 2
Loop
'if we get here then n is prime - add it as a factor
factors.Add Array(n, 1)
End Sub
Function factor(ByVal n As Long) As Collection
Dim factors As New Collection
Dim k As Long
Do While n Mod 2 ^ k = 0
k = k + 1
Loop
k = k - 1
If k > 0 Then
n = n / 2 ^ k
factors.Add Array(2, k)
End If
If n > 1 Then HelperFactor n, 3, factors
Set factor = factors
End Function
Function PerfectCubeByFactors(n As Long) As Boolean
Dim factors As Collection
Dim f As Variant
Set factors = factor(n)
For Each f In factors
If f(1) Mod 3 > 0 Then
PerfectCubeByFactors = False
Exit Function
End If
Next f
'if we get here:
PerfectCubeByFactors = True
End Function
Function PerfectCube(n As Long) As Boolean
Dim d As Long
d = DigitalRoot(n)
If d = 0 Or d = 1 Or d = 8 Or d = 9 Then
PerfectCube = PerfectCubeByFactors(n)
Else
PerfectCube = False
End If
End Function
Fixed the integer division error thanks to #Comintern. Seems to be correct up to 208064 ^ 3 - 2
Function isPerfectCube(n As Double) As Boolean
n = Abs(n)
isPerfectCube = n = Int(n ^ (1 / 3) - (n > 27)) ^ 3
End Function
I have this code below, and I'm getting an overflow error at the line:
s = s + (x Mod 10) [first line in the Do Loop]
Why? I declared x and s to be of type Double. Adding two doubles, why is this not working?
Thanks for your help.
Public Sub bidon1()
Dim i As Double, x As Double, s As Double, k As Byte, h As Byte
Dim y(1 To 6) As Double
For i = 1 To 1000000
x = i ^ 3
Do
s = s + (x Mod 10)
x = x \ 10
Loop Until x = 0
If s = x Then
k = k + 1
y(k) = x
If y(6) > 0 Then
For h = 1 To 6
Debug.Print y(h)
Next
Exit Sub
End If
End If
Next
End Sub
The problem is that the VBA mod operator coerces its arguments to be integers (if they are not already so). It is this implicit coercion which is causing the overflow. See this question: Mod with Doubles
On Edit:
Based on your comments, you want to be able to add together the digits in a largish integer. The following function might help:
Function DigitSum(num As Variant) As Long
'Takes a variant which represents an integer type
'such as Integer, Long or Decimal
'and returns the sum of its digits
Dim sum As Long, i As Long, s As String
s = CStr(num)
For i = 1 To Len(s)
sum = sum + Val(Mid(s, i, 1))
Next i
DigitSum = sum
End Function
The following test sub shows how it can be used to correctly get the sum of the digits in 999999^3:
Sub test()
Dim x As Variant, y As Variant
Debug.Print "Naive approach: " & DigitSum(999999 ^ 3)
y = CDec(999999)
x = y * y * y
Debug.Print "CDec approach: " & DigitSum(x)
End Sub
Output:
Naive approach: 63
CDec approach: 108
Since 999999^3 = 999997000002999999, only the second result is accurate. The first result is only the sum of the digits in the string representation of the double 999999^3 = 9.99997000003E+17
I am trying to find the x intercept of a 4th degree function by incrementing the x value. I feel like this way doesnt work always and isnt the most efficient way to do this, is there another way I am missing?
My code is:
Sub Findintercept()
Dim equation As Double, x As Double, A As Double, B As Double, C As Double, D As Double, E As Double
A = 0.000200878
B = -0.002203704
C = 0.0086
D = -0.02333
E = 0.02033
x = 0
equation = A * x ^ 4 + B * x ^ 3 + C * x ^ 2 + D * x + E
While (equation > 0.00001 Or equation < -0.00001)
If (x > 5) Then
MsgBox "Could not find intercept"
equation = 0
Else
x = x + 0.0001
equation = A * x ^ 4 + B * x ^ 3 + C * x ^ 2 + D * x + E
End If
Wend
MsgBox x
End Sub
Sometimes it fails to find the intercept hence the IF condition in the while loop. (Im always expecting the intercept to be less than 5!
Your method suffers from two problems:
You assume a step size to change x. The step could be too large, causing you to "walk past" the value your are looking for. To deal with this, you make a small step size, which can mean an excessively large number of iterations are needed to find the solution.
You always assume the same direction to change x. Even with seemingly small values for your step size, you could "walk past" the solution, and have no means to change direction. Or, your initial guess may be on the wrong side of the solution, and you never find an answer.
The Newton-Raphson method handles both of these issues neatly. You do still need to choose your initial guess somewhat close to the root you are looking for.
This method does have potential problems, but for polynomials such as the one you are dealing with, it is quite good.
Below is a simple VBA sub that implements this method. It solves your problem in 4 iterations. I recommend adjusting the initial guess (xii) a lot to see how it impacts the solution you get.
Sub SimpleNewtonRaphson()
Const Tol As Double = 1E-06
Const MaxIter As Long = 50
Dim xi As Double, xii As Double, deriv As Double
Dim IterCount As Long
' Initialize
xi = 0#
xii = 1#
IterCount = 0
' Method
Do While IterCount < MaxIter And Abs(xii - xi) > Tol
xi = xii
deriv = myDeriv(xi)
If deriv = 0# Then Exit Do
xii = xi - myFunc(xi) / deriv
IterCount = IterCount + 1
Loop
' Results
If deriv = 0 Then MsgBox "Ran into a 0 derivative, modify initial guess"
If IterCount >= MaxIter Then MsgBox "MaxIterations reached"
If Abs(xii - xi) <= Tol Then MsgBox "Solution found #" & vbCrLf & "F(" & xii & ") = " & myFunc(xii)
End Sub
... and two VBA functions for your equation and it's derivative ...
Function myFunc(x As Double) As Double
Const A As Double = 0.000200878
Const B As Double = -0.002203704
Const C As Double = 0.0086
Const D As Double = -0.02333
Const E = 0.02033
myFunc = A * x ^ 4 + B * x ^ 3 + C * x ^ 2 + D * x + E
End Function
Function myDeriv(x As Double) As Double
Const A As Double = 0.000200878
Const B As Double = -0.002203704
Const C As Double = 0.0086
Const D As Double = -0.02333
myDeriv = 4 * A * x ^ 3 + 3 * B * x ^ 2 + 2 * C * x + D
End Function
I'm trying to create a code that uses the false position method to find the roots of an equation. The equation is as follows:
y = x^(1.5sin(x)) * e^(-x/7) + e^(x/10) - 4
I used a calculator to find the roots, and they are 6.9025, 8.8719, and 12.8079.
My VBA code is as follows:
Option Explicit
Function Func(x)
Func = (x ^ (1.5 * Sin(x))) * Exp(-x / 7) + Exp(x / 10) - 4
End Function
Function FalsePos(Guess1, Guess2)
Dim a, b, c As Single
Dim i As Integer
a = Guess1
b = Guess2
For i = 0 To 1000
c = a - Func(a) * (b - a) / (Func(b) - Func(a))
If (Func(c) < 0.00001) Then
i = 1001
Else
If Func(a) * Func(c) < 0 Then
b = c
Else
a = c
End If
End If
Next
FalsePos = c
End Function
My problem is that when I call the function and use for example 4 and 8 as my two guesses, the number it returns is 5.29 instead of the root between 4 and 8 which is 6.9025.
Is there something wrong with my code or am I just not understanding the false position method correctly?
You should use Double for precision with Maths problems. Three other notes about coding that you may not be aware of:
dim a, b, c as Single
will dim a and b as Variants, and c as a Single, and you can use Exit For to escape from a for loop, rather than setting the control variable out of the bounds. Finally, you should define the outputs of a Function by specifying As ... after the closing parenthesis.
You should use breakpoints (press F9 with the carrot in a line of code to breakpoint that line), then step through the code by pressing F8 to advance line-by-line to see what is happening, and keep your eye on the Locals window (Go to View > Locals)
This is the code with the above changes:
Function Func(x As Double) As Double
Func = (x ^ (1.5 * Sin(x))) * Exp(-x / 7) + Exp(x / 10) - 4
End Function
Function FalsePos(Guess1 As Double, Guess2 As Double) As Double
Dim a As Double, b As Double, c As Double
Dim i As Integer
a = Guess1
b = Guess2
For i = 0 To 1000
c = a - Func(a) * (b - a) / (Func(b) - Func(a))
If (Func(c) < 0.00001) Then
Exit For
Else
If Func(a) * Func(c) < 0 Then
b = c
Else
a = c
End If
End If
Next
FalsePos = c
End Function
I am working an MS Access application a part of which uses Beta Distribution function. Since MS Access does not have Beta Distribution function of its own I'm using calling BetaDist function from MS Excel. I've tested the code in MS Excel and it seems to run successfully. In MS Access also the code is working fine and generating correct results but the time taken by Access is very high than the time taken by Excel. I'm posting the part of code which utilizes BetaDist function and also the slowest portion of the code. I want to reduce the time taken by Access. Any help is appreciated.
Part of Code which utilizes BetaDist:
For i = 1 To UBound(arrBetaParam)
If arrBetaParam(i).Alpha <= 0 Or arrBetaParam(i).Beta <= 0 Or tryOutValue > arrBetaParam(i).ExpValue Then
dblTempEP = 0
Else
If tryOutValue > arrBetaParam(i).LastKnownGoodValue Then
dblTempEP = 0
Else
dblTempEP = 1
End If
Dim bt As Double
bt = -1
On Error Resume Next
bt = Excel.WorksheetFunction.BetaDist(tryOutValue, arrBetaParam(i).Alpha, arrBetaParam(i).Beta, 0, arrBetaParam(i).ExpValue)
tj = bt
If bt > -1 Then
If bt > 1 Then bt = 1
If bt < 0 Then bt = 0
arrBetaParam(i).LastKnownGoodValue = tryOutValue
dblTempEP = 1 - bt
End If
On Error GoTo 0
End If
OEP = OEP + dblTempEP * arrBetaParam(i).Rate
'sumRate = sumRate + arrBetaParam(i).Rate
Next
Your code is probably taking so long due to the fact it has to open the Excel application.
BetaDist is not complicated to implement. Why not create a VBA function in Acces VBA. Here is the formula:
f(x) = B(alpha,beta)-1 xalpha-1(1-x)beta-1
Here I found a decent implementation. Didn't test it though:
Option Explicit
Const n As Long = 200 ' increase for accuracy, decrease for speed
Public aa As Double
Public bb As Double
Function BetaDist1(x As Double, a As Double, b As Double)
Dim d1 As Double
Dim d2 As Double
Dim n1 As Long
Dim n2 As Long
aa = a
bb = b
n1 = x * n
n2 = n - n1
d1 = SimpsonInt(0, x, n1)
d2 = SimpsonInt(x, 1, n2)
BetaDist1 = d1 / (d1 + d2)
End Function
Function SimpsonInt(ti As Double, tf As Double, ByVal n As Long) As Double
' shg 2006
' Returns the integral of Func (below) from ti to tf _
using Composite Simpson's Rule over n intervals
Dim i As Double ' index
Dim dH As Double ' step size
Dim dOdd As Double ' sum of Func(i), i = 1, 3, 5, 7, ... n-1, i.e., n/2 values
Dim dEvn As Double ' sum of Func(i), i = 2, 4, 6, ... n-2 i.e., n/2 - 1 values
' 1 + (n/2) + (n/2 - 1) + 1 = n+1 function evaluations
If n < 1 Then Exit Function
If n And 1 Then n = n + 1 ' n must be even
dH = (tf - ti) / n
For i = 1 To n - 1 Step 2
dOdd = dOdd + Func(ti + i * dH)
Next i
For i = 2 To n - 2 Step 2
dEvn = dEvn + Func(ti + i * dH)
Next i
SimpsonInt = (Func(ti) + 4# * dOdd + 2# * dEvn + Func(tf)) * dH / 3# ' weighted sum
End Function
Function Func(t As Double) As Double
Func = t ^ (aa - 1) * (1 - t) ^ (bb - 1)
End Function
You could do like this:
Dim xls As Excel.Application
Set xls = New Excel.Application
' Begin loop.
bt = xls.WorksheetFunction.BetaDist(tryOutValue, arrBetaParam(i).Alpha, arrBetaParam(i).Beta, 0, arrBetaParam(i).ExpValue)
' End loop.
xls.Quit
Set xls = Nothing