Related
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 want to compute for the binomial coefficient in Visual basic but I can only do the numerator part as I am lost on the denominator part. The equation that I am using is seen in the image below.
Equations
Looking at the C(n,k) equation, I can only do the numerator which is the n factorial. I am having trouble with the denominator. My code for the numerator (n!) is below:
Dim nfactorial As Integer = 1
For i As Integer = 1 To txt3.Text
nfactorial *= i
Next
What should I do about the denominator part? Thanks!
You can't separately calculate numerator and denominator. Have you try finding (30!) in .NET, especially with Integer ?
Is this a homework? Anyway, just take a look at following post: http://csharphelper.com/blog/2014/08/calculate-the-binomial-coefficient-n-choose-k-efficiently-in-c/
Code in vb:
Dim result As Decimal = 1
For i As Integer = 1 To K
result *= N - (K - i)
result /= i
Next
Return result
Try this:
'by example: C(5,3) = 10
Dim n, k As Integer
Dim result As String = ""
n = txt3.Text
For k = 0 To 3
result = result & "For C(" & n & "," & k & ")=" & C(n, k) & vbCrLf
Next
MsgBox(result)
.
.
.
Private Function C(n As Integer, k As Integer)
Dim result As Decimal = 1
For i As Integer = 1 To k
result *= n - (k - i)
result /= i
Next
Return result
End Function
EDIT: For k=0 to 3 and n entered by keyboard.
If I have a convex curve, and want to find the minimum point (x,y) using a for or while loop. I am thinking of something like
dim y as double
dim LastY as double = 0
for i = 0 to a large number
y=computefunction(i)
if lasty > y then exit for
next
how can I that minimum point? (x is always > 0 and integer)
Very Close
you just need to
dim y as double
dim smallestY as double = computefunction(0)
for i = 0 to aLargeNumber as integer
y=computefunction(i)
if smallestY > y then smallestY=y
next
'now that the loop has finished, smallestY should contain the lowest value of Y
If this code takes a long time to run, you could quite easily turn it into a multi-threaded loop using parallel.For - for example
dim y as Double
dim smallestY as double = computefunction(0)
Parallel.For(0, aLargeNumber, Sub(i As Integer)
y=computefunction(i)
if smallestY > y then smallestY=y
End Sub)
This would automatically create separate threads for each iteration of the loop.
For a sample function:
y = 0.01 * (x - 50) ^ 2 - 5
or properly written like this:
A minimum is mathematically obvious at x = 50 and y = -5, you can verify with google:
Below VB.NET console application, converted from python, finds a minimum at x=50.0000703584199, y=-4.9999999999505, which is correct for the specified tolerance of 0.0001:
Module Module1
Sub Main()
Dim result As Double = GoldenSectionSearch(AddressOf ComputeFunction, 0, 100)
Dim resultString As String = "x=" & result.ToString + ", y=" & ComputeFunction(result).ToString
Console.WriteLine(resultString) 'prints x=50.0000703584199, y=-4.9999999999505
End Sub
Function GoldenSectionSearch(f As Func(Of Double, Double), xStart As Double, xEnd As Double, Optional tol As Double = 0.0001) As Double
Dim gr As Double = (Math.Sqrt(5) - 1) / 2
Dim c As Double = xEnd - gr * (xEnd - xStart)
Dim d As Double = xStart + gr * (xEnd - xStart)
While Math.Abs(c - d) > tol
Dim fc As Double = f(c)
Dim fd As Double = f(d)
If fc < fd Then
xEnd = d
d = c
c = xEnd - gr * (xEnd - xStart)
Else
xStart = c
c = d
d = xStart + gr * (xEnd - xStart)
End If
End While
Return (xEnd + xStart) / 2
End Function
Function ComputeFunction(x As Double)
Return 0.01 * (x - 50) ^ 2 - 5
End Function
End Module
Side note: your initial attempt to find minimum is assuming a function is discrete, which is very unlikely in real life. What you would get with a simple for loop is a very rough estimate, and a long time to find it, as linear search is least efficient among other methods.
During some iterative optimization, the following VBA code for the computation of the bivariate normal CDF sometimes throws an Overflow error on the line with z = hx * hy * c inside the while loop of the upper function.
I debugged the code and the overflow occurs when the numbers being multiplied result in a number bigger than what a double can hold.
Can you show me how to handle the problem by ignoring the iterations of the loop with such high values - I guess that's the only feasible solution (?). I tried myself with a On Error Goto nextiteration line before the multiplication and placing the nextiteration jump point before the Wend, but the error persists.
Function tetrachoric(x As Double, y As Double, rho As Double) As Double
Const FACCURACY As Double = 0.0000000000001
Const MinStopK As Integer = 20
Dim k As Integer
Dim c As Double
Dim z As Double
Dim s As Double
Dim hx As Double
Dim hx1 As Double
Dim hx2 As Double
Dim hy As Double
Dim hy1 As Double
Dim hy2 As Double
Dim CheckPass As Integer
hx = 1
hy = 1
hx1 = 0
hy1 = 0
k = 0
c = rho
z = c
s = z
CheckPass = 0
While CheckPass < MinStopK
k = k + 1
hx2 = hx1
hy2 = hy1
hx1 = hx
hy1 = hy
hx = x * hx1 - (k - 1) * hx2
hy = y * hy1 - (k - 1) * hy2
c = c * rho / (k + 1)
z = hx * hy * c
s = s + z
If Abs(z / s) < FACCURACY Then
CheckPass = CheckPass + 1
Else
CheckPass = 0
End If
Wend
tetrachoric = s
End Function
Public Function bivnor(x As Double, y As Double, rho As Double) As Double
'
' bivnor function
' Calculates bivariat normal CDF F(x,y,rho) for a pair of standard normal
' random variables with correlation RHO
'
If rho = 0 Then
bivnor = Application.WorksheetFunction.NormSDist(x) * _
Application.WorksheetFunction.NormSDist(y)
Else
bivnor = Application.WorksheetFunction.NormSDist(x) * _
Application.WorksheetFunction.NormSDist(y) + _
Application.WorksheetFunction.NormDist(x, 0, 1, False) * _
Application.WorksheetFunction.NormDist(y, 0, 1, False) * _
tetrachoric(x, y, rho)
End If
End Function
Source: Available for download at http://michael.marginalq.com/
you're hitting on the limits of the computer architecture. Many complex algorithms can't be implemented 1:1 with their mathematical representation because of performance reasons and/or erroneous behavior when overflowing. There's an exceptionally good blog about these issues - John D. Cook.
Please take a look here for a better implementation.
You can also try binding an external library, that gives you arbitrary precision number handling, of course implemented using very expensive (in terms of CPU time) software algorithms. More can be found here.
Updated code using On Error Resume Next instead of On Error Goto:
While CheckPass < MinStopK
k = k + 1
hx2 = hx1
hy2 = hy1
hx1 = hx
hy1 = hy
hx = x * hx1 - (k - 1) * hx2
hy = y * hy1 - (k - 1) * hy2
c = c * rho / (k + 1)
On Error Resume Next
z = hx * hy * c
If Err.Number = 0 Then
s = s + z
If Abs(z / s) < FACCURACY Then
CheckPass = CheckPass + 1
Else
CheckPass = 0
End If
Else
Err.Clear
End If
Wend
http://www.codeproject.com/KB/recipes/float_point.aspx treats how to "Use Logarithms to Avoid Overflow and Underflow", which is a simple but quite effective way of working around overflow problems. In fact, it's so simple yet logical, why haven't we thought of that solution ourselves? ;)
How do I convert a indefinite decimal (i.e. .333333333...) to a string fraction representation (i.e. "1/3"). I am using VBA and the following is the code I used (i get an overflow error at the line "b = a Mod b":
Function GetFraction(ByVal Num As Double) As String
If Num = 0# Then
GetFraction = "None"
Else
Dim WholeNumber As Integer
Dim DecimalNumber As Double
Dim Numerator As Double
Dim Denomenator As Double
Dim a, b, t As Double
WholeNumber = Fix(Num)
DecimalNumber = Num - Fix(Num)
Numerator = DecimalNumber * 10 ^ (Len(CStr(DecimalNumber)) - 2)
Denomenator = 10 ^ (Len(CStr(DecimalNumber)) - 2)
If Numerator = 0 Then
GetFraction = WholeNumber
Else
a = Numerator
b = Denomenator
t = 0
While b <> 0
t = b
b = a Mod b
a = t
Wend
If WholeNumber = 0 Then
GetFraction = CStr(Numerator / a) & "/" & CStr(Denomenator / a)
Else
GetFraction = CStr(WholeNumber) & " " & CStr(Numerator / a) & "/" & CStr(Denomenator / a)
End If
End If
End If
End Function
As .333333333 is not 1/3 you will never get 1/3 but instead 333333333/1000000000 if you do not add some clever "un-rounding" logic.
Here is a solution for handling numbers with periodic decimal representation I remember from school.
A number 0.abcdabcd... equals abcd/9999. So 0.23572357... equals 2357/9999 exactly. Just take that many 9s as your pattern is long. 0.11111... equals 1/9, 0.121212... equals 12/99, and so on. So try just searching a pattern and setting the denominator to the corresponding number. Of course you have to stop after some digits because you will never know if the pattern is repeated for ever or just many times. And you will hit the rounding error in the last digit, so you still need some clever logic.
This only works in Excel-VBA but since you had it tagged "VBA" I will suggest it. Excel has a custom "fraction" format that you can access via "Format Cells" (or ctrl-1 if you prefer). This particular number format is Excel-Specific and so does not work with the VBA.Format function. It does however work with the Excel Formula TEXT(). (Which is the Excel equivalent of VBA.Format. This can be accessed like So:
Sub Example()
MsgBox Excel.WorksheetFunction.Text(.3333,"# ?/?")
End Sub
To show more than one digit (Example 5/12) just up the number of question marks.
Google for "decimal to fraction" and you'll get about a gazillion results.
I really like this one, because it's simple, has source code (in RPL, similar to Forth, ~25 lines), and is pretty fast (it's written to run on a 4-bit, 4MHz CPU). The docs say:
In a book called Textbook of Algebra by G. Chrystal, 1st
edition in 1889, in Part II, Chapter 32, this improved continued fraction
algorithm is presented and proven. Odd to tell, Chrystal speaks of it as if it
were ancient knowledge.
This site seem to have a really nice implementation of this in JavaScript.
I would multiply by 10000000(or whatever you want depending on the precision), then simplify the resulting fraction (ie n*10000000/10000000)
You can approximate it. Essentially cycle through all numerators and denominators until you reach a fraction that is close to what you want.
int num = 1;
int den = 1;
double limit == 0.1;
double fraction = num / den;
while(den < 1000000 ) // some arbitrary large denominator
{
den = den + 1;
for(num = 0; num <= den; num++)
{
fraction = num / den;
if(fraction < n + limit && fraction > n - limit)
return (num + "/" + den);
}
}
This is slow and a brute force algorithm, but you should get the general idea.
In general, it'll be easier if you find the repeating part of the rational number. If you can't find that, you'll have a tough time. Let's say the number if 8.45735735735...
The answer is 8 + 45/100 + 735/999/100 = 8 1523/3330.
The whole number is 8.
Add 45/100 - which is .45, the part before the repeating part.
The repeating part is 735/999. In general, take the repeating part. Make it the numerator. The denominator is 10^(number of repeating digits) - 1.
Take the repeating part and shift it the appropriate number of digits. In this case, two, which means divide by 100, so 735/999/100.
Once you figure those parts out, you just need some code that adds and reduces fractions using greatest common fractions ...
Similar to CookieOfFortune's, but it's in VB and doesn't use as much brute force.
Dim tolerance As Double = 0.1 'Fraction has to be at least this close'
Dim decimalValue As Double = 0.125 'Original value to convert'
Dim highestDenominator = 100 'Highest denominator you`re willing to accept'
For denominator As Integer = 2 To highestDenominator - 1
'Find the closest numerator'
Dim numerator As Integer = Math.Round(denominator * decimalValue)
'Check if the fraction`s close enough'
If Abs(numerator / denominator - decimalValue) <= tolerance Then
Return numerator & "/" & denominator
End If
Next
'Didn't find one. Use the highest possible denominator'
Return Math.Round(denominator * decimalValue) & "/" & highestDenominator
...Let me know if it needs to account for values greater than 1, and I can adjust it.
EDIT: Sorry for the goofed up syntax highlighting. I can't figure out why it's all wrong. If someone knows how I can make it better, please let me know.
Python has a nice routine in its fractions module. Here is the working portion that converts a n/d into the closest approximation N/D where D <= some maximum value. e.g. if you want to find the closest fraction to 0.347, let n=347,d=1000 and max_denominator be 100 and you will obtain (17, 49) which is as close as you can get for denominators less than or equal to 100. The '//' operator is integer division so that 2//3 gives 0, i.e. a//b = int(a/b).
def approxFrac(n,d,max_denominator):
#give a representation of n/d as N/D where D<=max_denominator
#from python 2.6 fractions.py
#
# reduce by gcd and only run algorithm if d>maxdenominator
g, b = n, d
while b:
g, b = b, g%b
n, d = n/g, d/g
if d <= max_denominator:
return (n,d)
nn, dd = n, d
p0, q0, p1, q1 = 0, 1, 1, 0
while True:
a = nn//dd
q2 = q0+a*q1
if q2 > max_denominator:
break
p0, q0, p1, q1 = p1, q1, p0+a*p1, q2
nn, dd = dd, nn-a*dd
k = (max_denominator-q0)//q1
bound1 = (p0+k*p1, q0+k*q1)
bound2 = (p1, q1)
if abs(bound2[0]*d - bound2[1]*n) <= abs(bound1[0]*d - bound1[1]*n):
return bound2
else:
return bound1
1/ .3333333333 = 3 because 1/3 = .3333333333333, so whatever number you get do this,
double x = 1 / yourDecimal;
int y = Math.Ceil(x);
and now Display "1/" + y
It is not allways resoluble, since not all decimals are fractions (for example PI or e).
Also, you have to round up to some length your decimal before converting.
I know this is an old thread, but I came across this problem in Word VBA. There are so many limitations due to the 8 bit (16 digit) rounding, as well as Word VBA making decimals into scientific notation etc.. but after working around all these problems, I have a nice function I'd like to share that offers a few extra features you may find helpful.
The strategy is along the lines of what Daniel Buckner wrote. Basically:
1st) decide if it's a terminating decimal or not
2nd) If yes, just set the decimal tail / 10^n and reduce the fraction.
3rd) If it doesn't terminate, try to find a repeating pattern including cases where the repetition doesn't start right away
Before I post the function, here are a few of my observations of the risks and limitations, as well as some notes that may help you understand my approach.
Risks, limitations, explanations:
-> Optional parameter "denom" allows you to specify the denominator of the fraction, if you'd like it rounded. i.e. for inches you may want 16ths used. The fractions will still be reduced, however, so 3.746 --> 3 12/16 --> 3 3/4
-> Optional parameter "buildup" set to True will build up the fraction using the equation editor, typing the text right into the active document. If you prefer to have the function simply return a flat string representation of the fraction so you can store it programmatically etc. set this to False.
-> A decimal could terminate after a bunch of repetitions... this function would assume an infinite repetition.
-> Variable type Double trades off whole number digit for decimal digits, only allowing 16 digits total (from my observations anyway!). This function assumes that if a number is using all 16 of the available digits then it must be a repeating decimal. A large number such as 123456789876.25 would be mistaken for a repeating decimal, then returned as decimal number upon failing to find a pattern.
-> To express really large terminating decimal out of 10^n, VB can only handle 10^8 is seems. I round the origninal number to 8 decimal places, losing some accuracy perhaps.
-> For the math behind converting repeating patterns to fractions check this link
-> Use Euclidean Algorithm to reduce the fraction
Ok, here it is, written as a Word Macro:
Function as_fraction(number_, Optional denom As Integer = -1, Optional buildup As Boolean = True) As String
'Selection.TypeText Text:="Received: " & CStr(number_) & vbCrLf
Dim number As Double
Dim repeat_digits As Integer, delay_digits As Integer, E_position As Integer, exponent As Integer
Dim tail_string_test As String, tail_string_original As String, num_removed As String, tail_string_removed As String, removed As String, num As String, output As String
output = "" 'string variable to build into the fraction answer
number = CDbl(number_)
'Get rid of scientific notation since this makes the string longer, fooling the function length = digits
If InStr(CStr(number_), "E+") > 0 Then 'no gigantic numbers! Return that scientific notation junk
output = CStr(number_)
GoTo all_done
End If
E_position = InStr(CStr(number), "E") 'E- since postives were handled
If E_position > 0 Then
exponent = Abs(CInt(Mid(CStr(number), E_position + 1)))
num = Mid(CStr(number_), 1, E_position) 'axe the exponent
decimalposition = InStr(num, ".") 'note the decimal position
For i_move = 1 To exponent
'move the decimal over, and insert a zero if the start of the number is reached
If InStr(num, "-") > 0 And decimalposition = 3 Then 'negative sign in front
num = "-0." & Mid(num, InStr(num, ".") - 1, 1) & Mid(num, InStr(num, ".") + 1) 'insert a zero after the negative
ElseIf decimalposition = 2 Then
num = "0." & Mid(num, InStr(num, ".") - 1, 1) & Mid(num, InStr(num, ".") + 1) 'insert in front
Else 'move the decimal over, there are digits left
num = Mid(num, 1, decimalposition - 2) & "." & Mid(num, decimalposition - 1, 1) & Mid(num, decimalposition + 1)
decimalposition = decimalposition - 1
End If
Next
Else
num = CStr(number_)
End If
'trim the digits to 15, since VB rounds the last digit which ruins the pattern. i.e. 0.5555555555555556 etc.
If Len(num) >= 16 Then
num = Mid(num, 1, 15)
End If
number = CDbl(num) 'num is a string representation of the decimal number, just to avoid cstr() everywhere
'Selection.TypeText Text:="number = " & CStr(number) & vbCrLf
'is it a whole number?
If Fix(number) = number Then 'whole number
output = CStr(number)
GoTo all_done
End If
decimalposition = InStr(CStr(num), ".")
'Selection.TypeText Text:="Attempting to find a fraction equivalent for " & num & vbCrLf
'is it a repeating decimal? It will have 16 digits
If denom = -1 And Len(num) >= 15 Then 'repeating decimal, unspecified denominator
tail_string_original = Mid(num, decimalposition + 1) 'digits after the decimal
delay_digits = -1 'the number of decimal place values removed from the tail, in case the repetition is delayed. i.e. 0.567777777...
Do 'loop through start points for the repeating digits
delay_digits = delay_digits + 1
If delay_digits >= Fix(Len(tail_string_original) / 2) Then
'Selection.TypeText Text:="Tried all starting points for the pattern, up to half way through the tail. None was found. I'll treat it as a terminating decimal." & vbCrLf
GoTo treat_as_terminating
End If
num_removed = Mid(num, 1, decimalposition) & Mid(num, decimalposition + 1 + delay_digits) 'original number with decimal values removed
tail_string_removed = Mid(num_removed, InStr(CStr(num_removed), ".") + 1)
repeat_digits = 0 'exponent on 10 for moving the decimal place over
'Selection.TypeText Text:="Searching " & num_removed & " for a pattern:" & vbCrLf
Do
repeat_digits = repeat_digits + 1
If repeat_digits = Len(tail_string_removed) - 1 Or repeat_digits >= 9 Then 'try removing a digit, incase the pattern is delayed
Exit Do
End If
tail_string_test = Mid(num_removed, decimalposition + 1 + repeat_digits)
'Selection.TypeText Text:=vbTab & "Comparing " & Mid(tail_string_removed, 1, Len(tail_string_removed) - repeat_digits) & " to " & tail_string_test & vbCrLf
If Mid(tail_string_removed, 1, Len(tail_string_removed) - repeat_digits) = tail_string_test Then
'Selection.TypeText Text:=num & ", " & Mid(tail_string_removed, 1, Len(tail_string_removed) - repeat_digits) & " vs " & tail_string_test & vbCrLf
GoTo foundpattern
End If
Loop
Loop 'next starting point for pattern
foundpattern:
If delay_digits = 0 Then 'found pattern right away
numerator = CLng(Mid(CStr(number), decimalposition + 1 + delay_digits, CInt(repeat_digits)))
'generate the denominator nines, same number of digits as the numerator
bottom = ""
For i_loop = 1 To repeat_digits
bottom = bottom & "9"
Next
denominator = CLng(bottom)
Else 'there were numbers before the pattern began
numerator = CLng(Mid(num, decimalposition + 1, delay_digits + repeat_digits)) - CLng(Mid(num, decimalposition + 1, delay_digits))
'i.e. x = 2.73232323232... delay_digits = 1, repeat_digits = 2, so numerator = 732 - 7 = 725
bottom = ""
For i_loop = 1 To repeat_digits
bottom = bottom & "9"
Next
For i_loop = 1 To delay_digits
bottom = bottom & "0"
Next
denominator = CLng(bottom)
'i.e. 990... 725/990 = 145/198 = 0.7323232...
End If
Else ' terminating decimal
treat_as_terminating:
'grab just the decimal trail
If denom = -1 Then
number = Math.Round(number, 8) 'reduce to fewer decimal places to avoid overload
'is it a whole number now?
If Fix(number) = number Then 'whole number
output = CStr(number)
GoTo all_done
End If
num = CStr(number)
numerator = CLng(Mid(num, decimalposition + 1))
denominator = 10 ^ (Len(num) - InStr(num, "."))
Else 'express as a fraction rounded to the nearest denom'th reduced
numerator1 = CDbl("0" & Mid(CStr(num), decimalposition))
numerator = CInt(Math.Round(numerator1 * denom))
denominator = CInt(denom)
End If
End If
'reduce the fraction if possible using Euclidean Algorithm
a = CLng(numerator)
b = CLng(denominator)
Dim t As Long
Do While b <> 0
t = b
b = a Mod b
a = t
Loop
gcd_ = a
numerator = numerator / gcd_
denominator = denominator / gcd_
whole_part = CLng(Mid(num, 1, decimalposition - 1))
'only write a whole number if the number is absolutely greater than zero, or will round to be so.
If whole_part <> 0 Or (whole_part = 0 And numerator = denominator) Then
'case where fraction rounds to whole
If numerator = denominator Then
'increase the whole by 1 absolutely
whole_part = (whole_part / Abs(whole_part)) * (Abs(whole_part) + 1)
End If
output = CStr(whole_part) & " "
End If
'if fraction rounded to a whole, it is already included in the whole number
If numerator <> 0 And numerator <> denominator Then
'negative sign may have been missed, if whole number was -0
If whole_part = 0 And number_ < 0 Then
numerator = -numerator
End If
output = output & CStr(numerator) & "/" & CStr(denominator) & " "
End If
If whole_part = 0 And numerator = 0 Then
output = "0"
End If
all_done:
If buildup = True Then 'build up the equation with a pretty fraction at the current selection range
Dim objRange As Range
Dim objEq As OMath
Dim AC As OMathAutoCorrectEntry
Application.OMathAutoCorrect.UseOutsideOMath = True
Set objRange = Selection.Range
objRange.Text = output
For Each AC In Application.OMathAutoCorrect.Entries
With objRange
If InStr(.Text, AC.Name) > 0 Then
.Text = Replace(.Text, AC.Name, AC.Value)
End If
End With
Next AC
Set objRange = Selection.OMaths.Add(objRange)
Set objEq = objRange.OMaths(1)
objEq.buildup
'Place the cursor at the end of the equation, outside of the OMaths object
objRange.OMaths(1).Range.Select
Selection.Collapse direction:=wdCollapseEnd
Selection.MoveRight Unit:=wdCharacter, count:=1
as_fraction = "" 'just a dummy return to make the function happy
Else 'just return a flat string value
as_fraction = output
End If
End Function
I shared an answer at this link : https://stackoverflow.com/a/57517128/11933717
It's also an iterative function, but unlike finding numerator and denominator in a nested loop, it just tests numerators only and so, should be faster.
Here is how it works :
It assumes that, based on the user input x, you want to find 2 integers n / m .
n/m = x , meaning that
n/x should give an almost integer m
Say one needs to find a fraction for x = 2.428571. Putting the int 2 aside for later, the algo starts by setting n and x and iterates n :
// n / x = m ( we need m to be an integer )
// n = 1 ; x = .428571 ;
1 / .428571 = 2.333335 (not close to an integer, n++)
2 / .428571 = 4.666671 (not close to an integer, n++)
3 / .428571 = 7.000007
At this point n = 3, we consider that m = 7.000007 is integer enough --based on some kind of accuracy the programmer decides-- and we reply the user
2.428571 = 2 + 3/7
= 14/7 + 3/7
= 17/7