The program keep saying that there is a division by zero in Term = (-1 ^ (i - 1)) * (X ^ (2 * (i - 1))) / M even though M was set to equal 1 before this calculation took place. I have tried change the value of M but it continuously keeps giving the division by 0 error message. This program is supposed to calculate sin(x) without using the built in function. Any insight towards this is very much appriciated.
Option Explicit
Sub MainPrg()
Dim X As Single, LastTerm As Long, M As Double, Term As Long, i As
Single, _
ActVal As Single, Sum As Long
'
'
X = InputBox("Please input the angle in degrees")
X = X * (3.14159 / 180)
LastTerm = InputBox("Please enter the largest value for the last
term in the series")
ActVal = Sin(X)
Call SinCalc(LastTerm, M, i, Term, Sum, X)
MsgBox ("The calculated value is " & Sum & " And the actual value
is " & ActVal)
End Sub
Function Fact(ByVal i As Single, ByRef M As Double)
M = M * (2 * (i - 1))
End Function
Sub SinCalc(ByVal LastTerm As Double, ByVal M As Double, ByVal i As
Single, _
ByRef Term As Long, ByRef Sum As Long, ByVal X As Single)
i = 1
M = 1
Sum = 0
Do
Term = (-1 ^ (i - 1)) * (X ^ (2 * (i - 1))) / M
Sum = Sum + Term
If (Abs(Term) < LastTerm) Then Exit Do
i = i + 1
Call Fact (i,M)
Loop
End Sub
Your line with the issue
Term = (-1 ^ (i - 1)) * (X ^ (2 * (i - 1))) / M
is inside a loop so even if at the beginning M is equal to 1 it can become equal to 0 after (this happens during the fact function)
Related
Hey I have no idea why I get an error "run time error 13 type mismatch". Thats my code and the place where I get an error:
EDIT: That is my code:
Function payoff(S_T, K, CallPut As String)
If CallPut = "call" Then
omega = 1
Else: omega = -1
End If
payoff = WorksheetFunction.Max(omega * (S_T - K), 0)
End Function
Function BS_trajektoria(S_0 As Double, T As Double, r As Double, q As Double, sigma As Double, N As Long) As Double()
Randomize
Dim S() As Double
Dim delta_t As Double
Dim i As Long
ReDim S(N)
S(0) = S_0
delta_t = T / N
For i = 1 To N
S(i) = S(i - 1) * Exp((r - q - 0.5 * sigma ^ 2) * delta_t + sigma * delta_t ^ 0.5 * Application.NormSInv(Rnd))
Next i
BS_trajektoria = S
End Function
Function barrier_MC(S_0 As Double, K As Double, T As Double, r As Double, q As Double, sigma As Double, _
B As Double, N As Long, num_of_sim As Long, CallPut As String, BarType As String) As Double
Randomize
Dim max_value As Double
Dim suma_wyplat As Double
Dim wyplata As Double
Dim i As Long
Dim S() As Double
suma_wyplat = 0
If (BarType = "DO" Or BarType = "DI") And B > S_0 Then
MsgBox "Too high barrier!"
Exit Function
ElseIf (BarType = "UO" Or BarType = "UI") And B < S_0 Then
MsgBox "Too low barrier!"
Exit Function
End If
With WorksheetFunction
For i = 1 To num_of_sim
S = BS_trajektoria(S_0, T, r, q, sigma, N)
max_value = .Max(S)
If max_value >= B Then
wyplata = 0
Else
wyplata = payoff(S(N), K, CallPut)
End If
suma_wyplat = suma_wyplat + wyplata
Next i
End With
barrier_MC = Exp(-r * T) * suma_wyplat / num_of_sim
End Function
Sub test3()
MsgBox barrier_MC(100, 100, 1, 0.05, 0.02, 0.2, 120, 1000, 1000000, "call", "UO")
End Sub
Anyone know where is the problem? For smaller value of N and num_of_sim everything works fine, the problem is when I use bigger values for these variables.
If you declare a new Double variable called rand and modify the main loop so that it looks like:
For i = 1 To N
rand = Rnd
S(i) = S(i - 1) * Exp((r - q - 0.5 * sigma ^ 2) * delta_t + sigma * delta_t ^ 0.5 * Application.NormSInv(rand))
Next i
you will see that the problem always happens when rand = 0. Why it throws that particular error is a bit of a mystery, but it is what it is. As a fix, what you could do is to keep the code as modified above with the following twist:
For i = 1 To N
rand = Rnd
If rand = 0 Then rand = 0.0000001
S(i) = S(i - 1) * Exp((r - q - 0.5 * sigma ^ 2) * delta_t + sigma * delta_t ^ 0.5 * Application.NormSInv(rand))
Next i
Then the code will run without error. It is still somewhat slow, but optimizing it (if possible) would be for a different question.
Beginner looper here...I am working on this well spacing project that looks at lat/longs and determines the next closest well. I think I may be creating an infinite loop or the program is just taking forever to run (It's looping through 15,000 rows). My main struggle has been trying to make sure each location is compared to every location in the dataset. From there I take the 2nd lowest distance (since the lowest will be zero when it compares to itself).
Sub WellSpacing()
Dim r As Integer, c As Integer, L As Integer, lastrow As Integer
Dim lat1 As Double, lat2 As Double, long1 As Double, long2 As Double
Dim distance As Double, d1 As Double, d2 As Double, d3 As Double
Dim PI As Double
PI = Application.WorksheetFunction.PI()
L = 2
r = 3
c = 10
lastrow = Sheets("Test").Cells(Rows.Count, "J").End(xlUp).Row
For L = 2 To lastrow
For r = 2 To lastrow
lat1 = Sheets("Test").Cells(L, c)
long1 = Sheets("Test").Cells(L, c + 1)
lat2 = Sheets("Test").Cells(r, c)
long2 = Sheets("Test").Cells(r, c + 1)
d1 = Sin((Abs((lat2 - lat1)) * PI / 180 / 2)) ^ 2 + Cos(lat1 * PI / 180) * Cos(lat2 * PI / 180) * Sin(Abs(long2 - long1) * PI / 180 / 2) ^ 2
d2 = 2 * Application.WorksheetFunction.Atan2(Sqr(1 - d1), Sqr(d1))
d3 = 6371 * d2 * 3280.84
Sheets("Working").Cells(r - 1, c - 9) = d3
Next r
Sheet2.Activate
Range("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending
distance = Sheet2.Range("A2")
Sheets("Test").Cells(L, c + 2) = distance
Sheet2.Range("A:A").Clear
Sheet1.Activate
Next L
End Sub
I've been working with geo-location math (aka, coordinate geometry) a lot lately and wrote a sub to do pretty much the same thing you're seeking.
Your code probably isn't creating an infinite loop, but calculating distances between thousands of coordinates can be very processor-intensive and even minor changes to your code can have a huge impact on processing time.
Calculating closest coordinate pair: Brute Force Method
There are a number of algorithms for determining closest points however the easiest to code (therefore possibly best for one-time use) is known as the Brute Force Method.
For p1 = 1 to numPoints
For p2 = p1 + 1 to numPoints
...calculate {distance}
...if {distance} < minDistance then minDist = {distance}
Next p2
Next p1
Using this method, distance will be calculated between x * ( n - 1 ) / 2 pairs of points.
For example, a list of 5 points would require 10 comparisons:
Point 1 ↔ Point 2
Point 1 ↔ Point 3
Point 1 ↔ Point 4
Point 1 ↔ Point 5
Point 2 ↔ Point 3
Point 2 ↔ Point 4
Point 2 ↔ Point 5
Point 3 ↔ Point 4
Point 3 ↔ Point 5
Point 4 ↔ Point 5
Since additional points will increase execution time exponentially, this method can create some lengthy processing times, especially on a slower machine or with an excessive number of points.
The methods I use for calculating distances between points and for comparing distances between lists of points are far from the [code-heavier] most-efficient alternatives, but they work for my "one-off" needs.
Depending on my purposes, I'll switch (almost identical code) between Excel & Access, but Access is much faster, so you may want to move your list into a table and do it that way.
One of the lists of points I compare has 252 items, which requires 31,628 individual comparisons using this "easy-code" method. In Excel, the process completes in 1.12 seconds, which is Access it only takes 0.16 seconds.
This may not seem like a big difference until we starting working with longer lists of points: another list of mine (closer to the size of yours) has about 12,000 points, which requires 71,994,000 calculations using the Brute Force method. In Access, the process completes in 8.6 minutes, so I estimate it would take about an hour in Excel.
Of course, all of these times are based on my operating system, processing power, Office version, etc. VBA isn't ideal for this level of computation, and everything you can do to reduce length of code will make a big difference, including commenting-out the status bar updates, immediate-window output, turn off screen updates, etc.
This code is a little messy & un-commented since I slapped it together for my own purposes, but it works for me. Let me know if you have any questions about how it works. All calculations are in metric but can be easily converted.
Sub findShortestDist_Excel()
Const colLatitude = "C" ' Col.C = Lat, Col.D = Lon
Dim pointList As Range, pointCount As Long, c As Range, _
arrCoords(), x As Long, y As Long
Dim thisDist As Double, minDist As Double, minDist_txt As String
Dim cntCurr As Long, cntTotal As Long, timerStart As Single
timerStart = Timer
Set pointList = Sheets("Stops").UsedRange.Columns(colLatitude)
pointCount = WorksheetFunction.Count(pointList.Columns(1))
'build array of numbers found in Column C/D
ReDim arrCoords(1 To 3, 1 To pointCount)
For Each c In pointList.Columns(1).Cells
If IsNumeric(c.Value) And Not IsEmpty(c.Value) Then
x = x + 1
arrCoords(1, x) = c.Value
arrCoords(2, x) = c.Offset(0, 1).Value
End If
Next c
minDist = -1
cntTotal = pointCount * (pointCount + 1) / 2
'loop through array
For x = 1 To pointCount
For y = x + 1 To pointCount
If (arrCoords(1, x) & arrCoords(2, x)) <> (arrCoords(1, y) & arrCoords(2, y)) Then
cntCurr = cntCurr + 1
thisDist = Distance(arrCoords(1, x), arrCoords(2, x), _
arrCoords(1, y), arrCoords(2, y))
'check if this distance is the smallest yet
If ((thisDist < minDist) Or (minDist = -1)) And thisDist > 0 Then
minDist = thisDist
'minDist_txt = arrCoords(1, x) & "," & arrCoords(2, x) & " -> " & arrCoords(1, y) & "," & arrCoords(2, y)
End If
'Application.StatusBar = "Calculating Distances: " & Format(cntCurr / cntTotal, "0.0%")
End If
Next y
'DoEvents
Next x
Debug.Print "Minimum distance: " & minDist_txt & " = " & minDist & " meters"
Debug.Print "(" & Round(Timer - timerStart, 2) & "sec)"
Application.StatusBar = "Finished. Minimum distance: " & minDist_txt & " = " & minDist & "m"
End Sub
Note that the procedure above is dependent on the following (which has slightly different versions for Access vs. Excel):
Excel: Calculate distance between points
Public Function Distance(ByVal lat1 As Double, ByVal lon1 As Double, _
ByVal lat2 As Double, ByVal lon2 As Double) As Double
'returns Meters distance in Excel (straight-line)
Dim theta As Double: theta = lon1 - lon2
Dim Dist As Double: Dist = Math.Sin(deg2rad(lat1)) * Math.Sin(deg2rad(lat2)) + Math.Cos(deg2rad(lat1)) * Math.Cos(deg2rad(lat2)) * Math.Cos(deg2rad(theta))
Dist = rad2deg(WorksheetFunction.Acos(Dist))
Distance = Dist * 60 * 1.1515 * 1.609344 * 1000
End Function
Function deg2rad(ByVal deg As Double) As Double
deg2rad = (deg * WorksheetFunction.PI / 180#)
End Function
Function rad2deg(ByVal rad As Double) As Double
rad2deg = rad / WorksheetFunction.PI * 180#
End Function
...and alternative code, for Microsoft Access:
Access: Shortest Distance
Sub findShortestDist_Access()
Const tableName = "Stops"
Dim pointCount As Long, arrCoords(), x As Long, y As Long
Dim thisDist As Double, minDist As Double
Dim cntCurr As Long, cntTotal As Long, timerStart As Single
Dim rs As Recordset
timerStart = Timer
Set rs = CurrentDb.OpenRecordset("SELECT * FROM " & tableName)
With rs
.MoveLast
.MoveFirst
pointCount = .RecordCount
'build array of numbers found in Column C/D
ReDim arrCoords(1 To 2, 1 To pointCount)
Do While Not .EOF
x = x + 1
arrCoords(1, x) = !stop_lat
arrCoords(2, x) = !stop_lon
.MoveNext
Loop
.Close
End With
minDist = -1
cntTotal = pointCount * (pointCount + 1) / 2
SysCmd acSysCmdInitMeter, "Calculating Distances:", cntTotal
'loop through array
For x = 1 To pointCount
For y = x + 1 To pointCount
cntCurr = cntCurr + 1
thisDist = Distance(arrCoords(1, x), arrCoords(2, x), _
arrCoords(1, y), arrCoords(2, y))
'check if this distance is the smallest yet
If ((thisDist < minDist) Or (minDist = -1)) And thisDist > 0 Then
minDist = thisDist
End If
SysCmd acSysCmdUpdateMeter, cntCurr
Next y
DoEvents
Next x
SysCmd acSysCmdRemoveMeter
Debug.Print "Minimum distance: " & minDist_txt & " = " & minDist & " meters"
Debug.Print "(" & Round(Timer - timerStart, 2) & "sec)"
End Sub
Note that the procedure above is dependent on the following... (Access may handle mass-calculations more quickly, but we have to build some functions ourselves that are built-in to Excel)
Access: Calculate distance between points
Const pi As Double = 3.14159265358979
Public Function Distance(ByVal lat1 As Double, ByVal lon1 As Double, _
ByVal lat2 As Double, ByVal lon2 As Double) As Double
'returns Meters distance in Access (straight-line)
Dim theta As Double: theta = lon1 - lon2
Dim dist As Double
dist = Math.Sin(deg2rad(lat1)) * Math.Sin(deg2rad(lat2)) + Math.Cos(deg2rad(lat1)) _
* Math.Cos(deg2rad(lat2)) * Math.Cos(deg2rad(theta))
dist = rad2deg(aCos(dist))
Distance = dist * 60 * 1.1515 * 1.609344 * 1000
End Function
Function deg2rad(ByVal deg As Double) As Double
deg2rad = (deg * pi / 180#)
End Function
Function rad2deg(ByVal rad As Double) As Double
rad2deg = rad / pi * 180#
End Function
Function aTan2(x As Double, y As Double) As Double
aTan2 = Atn(y / x)
End Function
Function aCos(x As Double) As Double
On Error GoTo aErr
If x = 0 Or Abs(x) = 1 Then
aCos = 0
Else
aCos = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
End If
Exit Function
aErr:
aCos = 0
End Function
Planar Case
Another method of calculating closer points is called Planar Case. I haven't seen any ready-to-use code samples and I don't need it bad enough to bother coding it, but the gist of it is this:
Read about this and more about the Closest pair of points problem on Wikipedia.
I would recommend using arrays as #Qharr said. I would also look to speed up the process by including some logic steps that avoid doing the complex math on every set of points.
What I mean is that you can do a Rough Estimate first to see whether or not to bother doing the actual calculations. I went with looking at whether or not either the Lat or Long of the current position is closer than the last closest point, but you could do anything you wanted.
I would change your code to something like:
Sub WellSpacing()
Dim R As Integer, C As Integer, L As Integer, LastRow As Integer, Shortest() As Integer
Dim Lats() As Double, Longs() As Double, Distances() As Double
Dim Distance As Double, D1 As Double, D2 As Double, D3 As Double
Dim PI As Double
On Error Resume Next
PI = Application.WorksheetFunction.PI()
L = 2
R = 3
C = 10
LastRow = Sheets("Test").Cells(Rows.Count, 10).End(xlUp).Row
ReDim Lats(1 To (LastRow - 1)) As Double
ReDim Longs(1 To (LastRow - 1)) As Double
ReDim Distances(1 To (LastRow - 1)) As Double
ReDim Shortest(1 To (LastRow - 1)) As Integer
For L = 2 To LastRow
Lats(L - 1) = Sheets("Test").Range("J" & L).Value
Longs(L - 1) = Sheets("Test").Range("K" & L).Value
Next L
For L = 1 To (LastRow - 1)
'This is a method of setting an initial value that can't be obtained through the caclucations (so you will know if any calcs have been done or not).
Distances(L) = -1
For R = 1 To (LastRow - 1)
'This minimises your calculations by 15,000 to begin with
If R = L Then GoTo Skip_This_R
'This skips checking the previous distances if it is the first calculation being checked.
If Distances(L) = -1 Then GoTo Skip_Check
'If there has already been a distance calculated, this does a rough check of whether the Lat or Long is closer. If neither
'the Lat or Long are closer than the current closest, then it will skip it. This reduces the code by 7 lines for most pairs.
If Abs(Lats(L) - Lats(R)) < Abs(Lats(L) - Lats(Shortest(L))) Or Abs(Longs(L) - Longs(R)) < Abs(Longs(L) - Longs(Shortest(L))) Then
Skip_Check:
D1 = Sin((Abs((Lats(R) - Lats(L))) * PI / 180 / 2)) ^ 2 + Cos(Lats(L) * PI / 180) * Cos(Lats(R) * PI / 180) * Sin(Abs(Longs(R) - Longs(L)) * PI / 180 / 2) ^ 2
D2 = 2 * Application.WorksheetFunction.Atan2(Sqr(1 - D1), Sqr(D1))
D3 = 6371 * D2 * 3280.84
If D3 < Distances(L) Or Distances(L) = -1 Then
Distances(L) = D3
'This stores the index value in the array of the closest Lat/Long point so far.
Shortest(L) = R
End If
End If
Skip_This_R:
Next R
'This puts the resulting closest distance into the corresponding cell.
Sheets("Test").Range("L" & (L + 1)).Value = Distances(L)
'This clears any previous comments on the cell.
Sheets("Test").Range("L" & (L + 1)).Comments.Delete
'This adds a nice comment to let you know which Lat/Long position it is closest to.
Sheets("Test").Range("L" & (L + 1)).AddComment "Matched to Row " & (Shortest(L) + 1)
Next L
End Sub
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'm currently writing VBA code for a lab for one of my engineering classes. The goal is to use a single function to approximate (Trapezoidal Rule) the integral of a given equation. The equation will need to change at some point. I'm new to programming so I'm planning on seeing some sort of simple logic error. Here's what I currently have:
Function Trapezoidal(ByVal sFx As String, ByVal A As Double, _
ByVal B As Double, ByVal N As Integer) As Double
' Calculates the area under the curve using the Trapezoidal rule.
'
' Parameters:
'
' sFx - String expression that has the function to be
' integrated. The variable X as to appear as $X.
' An example is: $X*LOG(X$) which is an expression for function
' f(x)=x*ln(x)
' A, B - Lower and Upper limit for the integral.
' N - The number of integration intervals.
'
Dim Sum As Double, DeltaX As Double, X As Double
Dim I As Integer
Sum = 0
DeltaX = (B - A) / N
X = A
For I = 1 To N
Sum = Sum + (Fx(sFx, X) + Fx(sFx, X + DeltaX)) / 2
X = X + DeltaX
Next I
Sum = DeltaX * Sum
Trapezoidal = Sum
End Function
I've sort of Frankensteined a few pieces of code together in my research.Something clearly isn
Sub Tester()
Debug.Print Trapezoidal("$X*LN($X)", 1, 20, 5)
End Sub
Function Trapezoidal(ByVal sFx As String, ByVal A As Double, _
ByVal B As Double, ByVal N As Integer) As Double
' Calculates the area under the curve using the Trapezoidal rule.
'
' Parameters:
'
' sFx - String expression that has the function to be
' integrated. The variable X as to appear as $X.
' An example is: $X*LOG(X$) which is an expression for function
' f(x)=x*ln(x)
' A, B - Lower and Upper limit for the integral.
' N - The number of integration intervals.
'
Dim Sum As Double, DeltaX As Double, X As Double
Dim I As Integer, f As String
Sum = 0
DeltaX = (B - A) / N
X = A
For I = 1 To N
'Sum = Sum + (Fx(sFx, X) + Fx(sFx, X + DeltaX)) / 2
f = "(" & Replace(sFx, "$X", X) & " + " & Replace(sFx, "$X", X + DeltaX) & ")/2"
Debug.Print f
Sum = Sum + Application.Evaluate(f)
X = X + DeltaX
Next I
Sum = DeltaX * Sum
Trapezoidal = Sum
End Function
Debug output:
(1*LN(1) + 4.8*LN(4.8))/2
(4.8*LN(4.8) + 8.6*LN(8.6))/2
(8.6*LN(8.6) + 12.4*LN(12.4))/2
(12.4*LN(12.4) + 16.2*LN(16.2))/2
(16.2*LN(16.2) + 20*LN(20))/2
502.848119401941