Related
I constantly use the website below to track air miles round trip. Recently, the website stopped working in IE, so my code did as well. Since I use this on a work computer, I cannot download many of the other solutions that I have found in my searches and I cannot use another website without going through a lengthy process to get the site approved. Is there a way to perform the same task here in Chrome without any other downloads?
Dim ele As Object
Dim IE As New InternetExplorer
IE.Visible = True
IE.navigate "http://www.distancefromto.net"
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
'step 1
With IE
.document.getElementsByName("distance")(0).Value = Range("B2").Value
.document.getElementsByName("distance")(1).Value = Range("B3").Value & Range("E3").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim a As String
a = Trim(.document.getElementById("totaldistancemiles").Value)
Dim aa As Variant
aa = Split(a, " ")
Range("C2").Value = aa(0)
'step 2
.document.getElementsByName("distance")(0).Value = Range("B4").Value & Range("E4").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim b As String
b = Trim(.document.getElementById("totaldistancemiles").Value)
Dim bb As Variant
bb = Split(b, " ")
Range("C3").Value = bb(0)
'step 3
.document.getElementsByName("distance")(1).Value = Range("B2").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim c As String
c = Trim(.document.getElementById("totaldistancemiles").Value)
Dim cc As Variant
cc = Split(c, " ")
Range("C4").Value = cc(0)
End With
IE.Quit
Any help, even a definitive "no, it's not possible" would be greatly appriciated
Thanks
Chrome:
To use Chrome - no. You would need to download selenium basic or use a different programming language e.g python.
Different site:
You could switch to using a different site (appreciate there may some minor differences on your prior figures due to the website though technically the distances shouldn’t have changed that much!). I note you say that this would be problematic. At the risk of sounding stalkerish, you have used freemaptools before so that might be an acceptable choice?
API:
If you find a site offering an API service you might be able to ditch all the above and issue an XMLHTTP request. I couldn't see your site offering an API service otherwise that would have been the obvious next choice.
#RahulChalwa mentions "[the site OP is using is itself using a wrapper around google maps API: https://maps.googleapis.com/maps/api/js/GeocodeService.Search. User can register for API and do a POST request]"; so that might be the way forward. Main documentation here.
E.g. API site: Personal and small scale use API - wheretocredit.com
Current set-up debug:
Ascertain the reason for IE no longer working in your current set-up would also be advisable, perhaps by contacting the site developers and raising your issue.
Perform the calculation (as the site does) using the Vincenty's formula or, as other sites do, using Haversine formula:
Haversine:
VBA haversine formula
Vicenty's (including sample code):
How to Calculate Distance in Excel
Vicenty's code from Contextures. I have attributed but if this should not be included here I will remove.
'*************************************************************
Private Const PI = 3.14159265358979
Private Const EPSILON As Double = 0.000000000001
Public Function distVincenty(ByVal lat1 As Double, ByVal lon1 As Double, _
ByVal lat2 As Double, ByVal lon2 As Double) As Double
'INPUTS: Latitude and Longitude of initial and
' destination points in decimal format.
'OUTPUT: Distance between the two points in Meters.
'
'======================================
' Calculate geodesic distance (in m) between two points specified by
' latitude/longitude (in numeric [decimal] degrees)
' using Vincenty inverse formula for ellipsoids
'======================================
' Code has been ported by lost_species from www.aliencoffee.co.uk to VBA
' from javascript published at:
' https://www.movable-type.co.uk/scripts/latlong-vincenty.html
' * from: Vincenty inverse formula - T Vincenty, "Direct and Inverse Solutions
' * of Geodesics on the Ellipsoid with application
' * of nested equations", Survey Review, vol XXII no 176, 1975
' * https://www.ngs.noaa.gov/PUBS_LIB/inverse.pdf
'Additional Reference: https://en.wikipedia.org/wiki/Vincenty%27s_formulae
'======================================
' Copyright lost_species 2008 LGPL
' https://www.fsf.org/licensing/licenses/lgpl.html
'======================================
' Code modifications to prevent "Formula Too Complex" errors
' in Excel (2010) VBA implementation
' provided by Jerry Latham, Microsoft MVP Excel Group, 2005-2011
' July 23 2011
'======================================
Dim low_a As Double
Dim low_b As Double
Dim f As Double
Dim L As Double
Dim U1 As Double
Dim U2 As Double
Dim sinU1 As Double
Dim sinU2 As Double
Dim cosU1 As Double
Dim cosU2 As Double
Dim lambda As Double
Dim lambdaP As Double
Dim iterLimit As Integer
Dim sinLambda As Double
Dim cosLambda As Double
Dim sinSigma As Double
Dim cosSigma As Double
Dim sigma As Double
Dim sinAlpha As Double
Dim cosSqAlpha As Double
Dim cos2SigmaM As Double
Dim C As Double
Dim uSq As Double
Dim upper_A As Double
Dim upper_B As Double
Dim deltaSigma As Double
Dim s As Double ' final result, will be returned rounded to 3 decimals (mm).
'added by JLatham to break up "Too Complex" formulas
'into pieces to properly calculate those formulas as noted below
'and to prevent overflow errors when using
'Excel 2010 x64 on Windows 7 x64 systems
Dim P1 As Double ' used to calculate a portion of a complex formula
Dim P2 As Double ' used to calculate a portion of a complex formula
Dim P3 As Double ' used to calculate a portion of a complex formula
'See https://en.wikipedia.org/wiki/World_Geodetic_System
'for information on various Ellipsoid parameters for other standards.
'low_a and low_b in meters
' === GRS-80 ===
' low_a = 6378137
' low_b = 6356752.314245
' f = 1 / 298.257223563
'
' === Airy 1830 === Reported best accuracy for England and Northern Europe.
' low_a = 6377563.396
' low_b = 6356256.910
' f = 1 / 299.3249646
'
' === International 1924 ===
' low_a = 6378388
' low_b = 6356911.946
' f = 1 / 297
'
' === Clarke Model 1880 ===
' low_a = 6378249.145
' low_b = 6356514.86955
' f = 1 / 293.465
'
' === GRS-67 ===
' low_a = 6378160
' low_b = 6356774.719
' f = 1 / 298.247167
'=== WGS-84 Ellipsoid Parameters ===
low_a = 6378137 ' +/- 2m
low_b = 6356752.3142
f = 1 / 298.257223563
'====================================
L = toRad(lon2 - lon1)
U1 = Atn((1 - f) * Tan(toRad(lat1)))
U2 = Atn((1 - f) * Tan(toRad(lat2)))
sinU1 = Sin(U1)
cosU1 = Cos(U1)
sinU2 = Sin(U2)
cosU2 = Cos(U2)
lambda = L
lambdaP = 2 * PI
iterLimit = 100 ' can be set as low as 20 if desired.
While (Abs(lambda - lambdaP) > EPSILON) And (iterLimit > 0)
iterLimit = iterLimit - 1
sinLambda = Sin(lambda)
cosLambda = Cos(lambda)
sinSigma = Sqr(((cosU2 * sinLambda) ^ 2) + _
((cosU1 * sinU2 - sinU1 * cosU2 * cosLambda) ^ 2))
If sinSigma = 0 Then
distVincenty = 0 'co-incident points
Exit Function
End If
cosSigma = sinU1 * sinU2 + cosU1 * cosU2 * cosLambda
sigma = Atan2(cosSigma, sinSigma)
sinAlpha = cosU1 * cosU2 * sinLambda / sinSigma
cosSqAlpha = 1 - sinAlpha * sinAlpha
If cosSqAlpha = 0 Then 'check for a divide by zero
cos2SigmaM = 0 '2 points on the equator
Else
cos2SigmaM = cosSigma - 2 * sinU1 * sinU2 / cosSqAlpha
End If
C = f / 16 * cosSqAlpha * (4 + f * (4 - 3 * cosSqAlpha))
lambdaP = lambda
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate lambda
'lambda = L + (1 - C) * f * sinAlpha * _
(sigma + C * sinSigma * (cos2SigmaM + C * cosSigma * _
(-1 + 2 * (cos2SigmaM ^ 2))))
'calculate portions
P1 = -1 + 2 * (cos2SigmaM ^ 2)
P2 = (sigma + C * sinSigma * (cos2SigmaM + C * cosSigma * P1))
'complete the calculation
lambda = L + (1 - C) * f * sinAlpha * P2
Wend
If iterLimit < 1 Then
MsgBox "iteration limit has been reached, something didn't work."
Exit Function
End If
uSq = cosSqAlpha * (low_a ^ 2 - low_b ^ 2) / (low_b ^ 2)
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate upper_A
'upper_A = 1 + uSq / 16384 * (4096 + uSq * _
(-768 + uSq * (320 - 175 * uSq)))
'calculate one piece of the equation
P1 = (4096 + uSq * (-768 + uSq * (320 - 175 * uSq)))
'complete the calculation
upper_A = 1 + uSq / 16384 * P1
'oddly enough, upper_B calculates without any issues - JLatham
upper_B = uSq / 1024 * (256 + uSq * (-128 + uSq * (74 - 47 * uSq)))
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate deltaSigma
'deltaSigma = upper_B * sinSigma * (cos2SigmaM + upper_B / 4 * _
(cosSigma * (-1 + 2 * cos2SigmaM ^ 2) _
- upper_B / 6 * cos2SigmaM * (-3 + 4 * sinSigma ^ 2) * _
(-3 + 4 * cos2SigmaM ^ 2)))
'calculate pieces of the deltaSigma formula
'broken into 3 pieces to prevent overflow error that may occur in
'Excel 2010 64-bit version.
P1 = (-3 + 4 * sinSigma ^ 2) * (-3 + 4 * cos2SigmaM ^ 2)
P2 = upper_B * sinSigma
P3 = (cos2SigmaM + upper_B / 4 * (cosSigma * (-1 + 2 * cos2SigmaM ^ 2) _
- upper_B / 6 * cos2SigmaM * P1))
'complete the deltaSigma calculation
deltaSigma = P2 * P3
'calculate the distance
s = low_b * upper_A * (sigma - deltaSigma)
'round distance to millimeters
distVincenty = Round(s, 3)
End Function
Function SignIt(Degree_Dec As String) As Double
'Input: a string representation of a lat or long in the
' format of 10° 27' 36" S/N or 10~ 27' 36" E/W
'OUTPUT: signed decimal value ready to convert to radians
'
Dim decimalValue As Double
Dim tempString As String
tempString = UCase(Trim(Degree_Dec))
decimalValue = Convert_Decimal(tempString)
If Right(tempString, 1) = "S" Or Right(tempString, 1) = "W" Then
decimalValue = decimalValue * -1
End If
SignIt = decimalValue
End Function
Function Convert_Degree(Decimal_Deg) As Variant
'source: https://support.microsoft.com/kb/213449
'
'converts a decimal degree representation to deg min sec
'as 10.46 returns 10° 27' 36"
'
Dim degrees As Variant
Dim minutes As Variant
Dim seconds As Variant
With Application
'Set degree to Integer of Argument Passed
degrees = Int(Decimal_Deg)
'Set minutes to 60 times the number to the right
'of the decimal for the variable Decimal_Deg
minutes = (Decimal_Deg - degrees) * 60
'Set seconds to 60 times the number to the right of the
'decimal for the variable Minute
seconds = Format(((minutes - Int(minutes)) * 60), "0")
'Returns the Result of degree conversion
'(for example, 10.46 = 10° 27' 36")
Convert_Degree = " " & degrees & "° " & Int(minutes) & "' " _
& seconds + Chr(34)
End With
End Function
Function Convert_Decimal(Degree_Deg As String) As Double
'source: https://support.microsoft.com/kb/213449
' Declare the variables to be double precision floating-point.
' Converts text angular entry to decimal equivalent, as:
' 10° 27' 36" returns 10.46
' alternative to ° is permitted: Use ~ instead, as:
' 10~ 27' 36" also returns 10.46
Dim degrees As Double
Dim minutes As Double
Dim seconds As Double
'
'modification by JLatham
'allow the user to use the ~ symbol instead of ° to denote degrees
'since ~ is available from the keyboard and ° has to be entered
'through [Alt] [0] [1] [7] [6] on the number pad.
Degree_Deg = Replace(Degree_Deg, "~", "°")
' Set degree to value before "°" of Argument Passed.
degrees = Val(Left(Degree_Deg, InStr(1, Degree_Deg, "°") - 1))
' Set minutes to the value between the "°" and the "'"
' of the text string for the variable Degree_Deg divided by
' 60. The Val function converts the text string to a number.
minutes = Val(Mid(Degree_Deg, InStr(1, Degree_Deg, "°") + 2, _
InStr(1, Degree_Deg, "'") - InStr(1, Degree_Deg, "°") - 2)) / 60
' Set seconds to the number to the right of "'" that is
' converted to a value and then divided by 3600.
seconds = Val(Mid(Degree_Deg, InStr(1, Degree_Deg, "'") + _
2, Len(Degree_Deg) - InStr(1, Degree_Deg, "'") - 2)) / 3600
Convert_Decimal = degrees + minutes + seconds
End Function
Private Function toRad(ByVal degrees As Double) As Double
toRad = degrees * (PI / 180)
End Function
Private Function Atan2(ByVal X As Double, ByVal Y As Double) As Double
' code nicked from:
' https://en.wikibooks.org/wiki/Programming:Visual_Basic_Classic
' /Simple_Arithmetic#Trigonometrical_Functions
' If you re-use this watch out: the x and y have been reversed from typical use.
If Y > 0 Then
If X >= Y Then
Atan2 = Atn(Y / X)
ElseIf X <= -Y Then
Atan2 = Atn(Y / X) + PI
Else
Atan2 = PI / 2 - Atn(X / Y)
End If
Else
If X >= -Y Then
Atan2 = Atn(Y / X)
ElseIf X <= Y Then
Atan2 = Atn(Y / X) - PI
Else
Atan2 = -Atn(X / Y) - PI / 2
End If
End If
End Function
'======================================
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 solve the following system of equations in VBA:
I have looked for other similar questions and I can't find any with suitable solutions. I have already solved the equations in a worksheet by simply entering the equations as formulae is separate cells (which will initially create a circular reference warning) and the enabling iterative calculation) - given that I know DR will always be greater than PR, I thought an iterative approach of incrementally reducing PR from an initial value of DR would work in VBA. For reference, the worksheet used is shown below:
The formula in G9 is =(G8*B6)/(G10+273.15), i.e. equation 2 (see above), and the formula in G10 is =(B6+(B6*(-1+((G9*(B3-B35))/(B3-B35))^0.263)/B34))-B33*(B6+(B6*(-1+((G9*(B3-B35))/(B3-B35))^0.263)/B34)), i.e. equation 1 (see above).
When I try to do this programmatically in VBA by reducing PR incrementally from an initial value of DR, it doesn't work. My code is below:
Sub ChargeTempAndPressureCalculations()
Dim AP_hPa As Double
Dim AP_psi As Double
Dim TIn_C As Double
Dim TIn_K As Double
Dim PR As Double
Dim Ei As Double
Dim Et As Double
Dim Vci As Double
Dim DR As Double
Dim TOut_C As Double
AP_hPa = 1029 'Input
AP_psi = AP_hPa * 100 * 0.000145038
TIn_C = 15 'Input
TIn_K = TIn_C + 273.15
Et = 0.75 'Input
Ei = 0.75 'Input
Vci = 0.5 'Input
DR = 2.7103502887329 'Input
PR = DR
Do Until TOut_C = (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et)) - Ei * (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et)) And PR = (DR * TIn_K) / (TOut_C + 273)
PR = PR - 0.00000000001
Loop
Debug.Print "Charge air temperature = " & TOut_C
Debug.Print "Pressure Ratio = " & PR
End Sub
It's clearly the loop that's the issue but what is it that I'm doing wrong?
Edit:
I've split equation 1 to prevent the 'Equation too complex' error observed by another user, mentioned in the comments. I've also added a control to prevent the number of steps going above 1000.
Sub ChargeTempAndPressureCalculations()
Dim AP_hPa As Double
Dim AP_psi As Double
Dim TIn_C As Double
Dim TIn_K As Double
Dim PR As Double
Dim Ei As Double
Dim Et As Double
Dim Vci As Double
Dim DR As Double
Dim TOut_C As Double
Dim A As Double
Dim B As Double
Dim i As Integer
AP_hPa = 1029 'Input
AP_psi = AP_hPa * 100 * 0.000145038
TIn_C = 15 'Input
TIn_K = TIn_C + 273.15
Et = 0.75 'Input
Ei = 0.75 'Input
Vci = 0.5 'Input
DR = 2.7103502887329 'Input
PR = DR
Do Until i > 1000 Or (TOut_C = A - Ei * B And PR = (DR * TIn_K) / (TOut_C + 273))
'Spliting equation for TOut_C to simplify the expression and prevent an error
A = (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et))
B = (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et))
PR = PR - 0.00000000001
i = i + 1
Loop
Debug.Print "Charge air temperature = " & TOut_C
Debug.Print "Pressure Ratio = " & PR
End Sub
Having read the answer provided, I'm still none the wiser as to how to resolve my issue.
I've gone over your calculation a bit more and I presume you want to stop if the increment of PR and TOut_C is very marginal...
The below code does exactly that. It calculates TOut_C at a given PR, it subsequently calculates the PR corresponding to that TOut_C, the loop then substitutes the newly calculated PR into the TOut_C calculation and so on.
It calculates the difference between the substitute calculation and the previous calculation and if there is no longer a 'large' offset between the two it stops the loop.
Sub ChargeTempAndPressureCalculations()
Dim AP_hPa As Double
Dim AP_psi As Double
Dim TIn_C As Double
Dim TIn_K As Double
Dim PR As Double
Dim Ei As Double
Dim Et As Double
Dim Vci As Double
Dim DR As Double
Dim TOut_C As Double
AP_hPa = 1029 'Input
AP_psi = AP_hPa * 100 * 0.000145038
TIn_C = 15 'Input
TIn_K = TIn_C + 273.15
Et = 0.75 'Input
Ei = 0.75 'Input
Vci = 0.5 'Input
DR = 2.7103502887329 'Input
PR = DR
dTOut_C = 1 'Set to arbitrary number to initialize the loop
dPR = 1 'Set to arbitrary number to initialize the loop
Do Until dPR < 0.0000000001 And dTOut_C < 0.0000000001
'Calculate the TOut_C and PR
TOut_C = (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et)) - Ei * (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et))
PR = (DR * TIn_K) / (TOut_C + 273)
'Calculate difference relative to last calculation
dPR = PR - PR0
dTOut_C = TOut_C - TOut_C0
'Set the last calculation as previous calculation and re-do loop
PR0 = PR
TOut_C0 = TOut_C
Loop
Debug.Print "Charge air temperature = " & TOut_C
Debug.Print "Pressure Ratio = " & PR
End Sub
Given your initial input the output is:
Charge air temperature = 93.2076926574912
Pressure Ratio = 2.13263525413933
Was that what you were looking for ?
PS: Technically what you should do is mathematically rewrite the equation to solve for PR based on DR as that is in essence what you are doing...
Note that in:
Do Until TOut_C = ...
the = sign is a comparisson and not an assignment. As TOut_C has not been used yet, it is set to zero by VB and so you are comparing whether the right hand side is zero. This does not seem to be your intention, as you use TOut_C in the AND part as TOut_C + 273 which then would always be 273.
But if you want to compare with zero, then note that the RHS will probably never become zero in floating point arithmetic and you must compare with an "epsilon", a small value that is your precission threshold. For example:
Private Const eps = 0.00000000001 ' must be smaller than your step size
Do Until Abs(TOut_C - RHS) < eps
I leave fixing this to you. (I also get an error "Expression too complex" on my Excel version.)
There is primarily two problems...
In your Do..Loop you want the code to break on TOut_C = <something based on PR> AND PR = <something based on TOut_C>
Both equation however lead to a double datatype, this is almost imposibble to have that be an = comparison as the likelyhood of hitting that equal point are virtualy zero (as I explained here)
So, you would want to set a more flexible parameter such as TOut_C > 63 for example.
The second thing that I can find is that the equations are just that, equations. So they'll produce a number but as that number is the result of the equation, but what would define the endpoint ? TOut_C is never defined and subsequently compared as indicated, your code starts with PR being 2.71... but Tout_C is 0.
So could you elaborate more on the correlation between TOut_C and PR and what would be the solution values for either or both of them ? Or are you trying to solve a balance point i.e. for a which TOut_C do both functions achieve the same result ? (That would require mathematically re-writing either function to express the same output) So rewrite the function for PR to produce Tout_C...
The loop works (i.e. it loops) if you write it like so...
It doesn't solve it, but at least you know it loops...
Do Until TOut_C = 15 And PR = 22
TOut_C = (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et)) - Ei * (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et))
PR = (DR * TIn_K) / (TOut_C + 273)
PR = PR - 0.00000000001
Loop
See http://www.decisionmodels.com/calcsecretsc.htm on how Excel processes circular references. Basically, it just calculates each cell, ignoring the circular reference and then it updates the values in each iteration.
Applying this to your VBA routine produces the following sub routine:
Sub ChargeTempAndPressureCalculations()
' input variables
Dim AP_hPa As Double
Dim AP_psi As Double
Dim TIn_C As Double
Dim TIn_K As Double
Dim Ei As Double
Dim Et As Double
Dim Vci As Double
Dim DR As Double
' temporary variables
Dim Td As Double
Dim Pd As Double
Dim A As Double
' output variables
Dim TOut_C As Double
Dim PR As Double
' iteration control
Dim eps As Double
Dim i As Integer
AP_hPa = 1029
AP_psi = AP_hPa * 100 * 0.000145038
TIn_C = 15
TIn_K = TIn_C + 273.15
Et = 0.75
Ei = 0.75
Vci = 0.5
DR = 2.7103502887329
PR = DR
eps = 0.00000000001
i = 0
Do
Td = TOut_C ' remember values from previous iteration ( 'd' means 'delta')
Pd = PR
A = (TIn_K + (TIn_K * (-1 + ((PR * (AP_psi - Vci)) / (AP_psi - Vci)) ^ 0.263) / Et))
TOut_C = A - Ei * A
PR = (DR * TIn_K) / (TOut_C + 273)
i = i + 1
Debug.Print TOut_C & ", " & PR & "(" & Abs(Td - TOut_C) & ", " & Abs(Pd - PR) & ")" ' show progression
' loop until the difference is less than eps or max iterations reached
Loop While (i < 100 And (Abs(Td - TOut_C) > eps And Abs(Pd - PR) > eps))
Debug.Print "Charge air temperature = " & TOut_C
Debug.Print "Pressure Ratio = " & PR
Debug.Print "number of iterations: " & i
End Sub
Output:
100.835921416446, 2.08911822261291(100.835921416446, 0.621232066119993)
92.5738330344343, 2.13633297880164(8.26208838201211, 4.72147561887288E-02)
93.2611120407512, 2.13232420812257(0.687279006316899, 4.00877067907057E-03)
93.2031960023579, 2.13266144103602(5.79160383933299E-02, 3.37232913455665E-04)
93.2080712078647, 2.13263304962791(4.87520550686327E-03, 2.83914081067316E-05)
93.2076607895546, 2.13263543972443(4.10418310181626E-04, 2.39009651137323E-06)
93.2076953402811, 2.13263523851592(3.45507265677725E-05, 2.01208508077144E-07)
93.2076924316548, 2.1326352554545(2.90862628560262E-06, 1.6938581648418E-08)
93.2076926765153, 2.13263525402854(2.44860444809092E-07, 1.42596112695514E-09)
93.2076926559019, 2.13263525414858(2.06133563551703E-08, 1.200430865822E-10)
93.2076926576372, 2.13263525413848(1.73530168012803E-09, 1.01052499701382E-11)
93.2076926574912, 2.13263525413933(1.46073375617561E-10, 8.5043083686287E-13)
Charge air temperature = 93.2076926574912
Pressure Ratio = 2.13263525413933
number of iterations: 12
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
I am trying to implement a 2D Perlin Noise in VB.Net. I've spent the whole day searching for sources that explain the subject and one of the most notable was this article by Hugo Elias
Most of the implementation went well. On the exception of a very important part that did not seem to work in VB.Net, causing overflows.
function Noise1(integer x, integer y)
n = x + y * 57
n = (n<<13) ^ n;
return ( 1.0 - ( (n * (n * n * 15731 + 789221) + 1376312589) & 7fffffff) / 1073741824.0);
end function
In VB.net I translated it to
Private Function Noise(tX As Integer, tY As Integer) As Double
'Return a double between -1 & 1 according to a fixed random seed
Dim n As Integer = tX + tY * 57
n = (n << 13) Xor n
Return (1.0 - ((n * (n * n * 15731 + 789221) + BaseSeed) And &H7FFFFFFF) / 1073741824.0)
End Function
Which cause overflows.
Since the idea seem to be to simply generate a fractional number between -1 and 1. I've made this little function which create a Integer Number based on the coordinates and BaseSeed. BaseSeed(999999) being the base for every noise I'll create in this particular part of my game.
Private Function Noise(tX As Integer, tY As Integer) As Double
Dim tSeed As Integer
tSeed = WrapInteger(789221, BaseSeed, (tX * 1087) + (tY * 2749))
RandomGenerator = New Random(tSeed)
Return (RandomGenerator.Next(-10000, 10001) / 10000)
End Function
WrapInteger simply makes sure that the number will always be in the range of an integer, to avoid overflow errors.
Public Function WrapInteger(ByVal Lenght As Integer, ByVal Position As Integer, ByVal Movement As Integer) As Integer
Lenght += 1
Return ((Position + Movement) + (Lenght * ((Abs(Movement) \ Lenght) + 1))) Mod Lenght
End Function
When I fire it up with a Persistence of 0.25, 6 Octaves and a starting frequency of 2. this is what I get. This is a 128x128 pixel bitmap that I scaled.
Result
Anyone have an idea of why it would be so linear? When I look at this picture I have the feeling that it's not far from the truth, as if it only worked in 1D. All suposition.
Below you will find my entire PerlinNoise Class. I think the rest of it is just fine, but I added it for reference purpose. Beside, I haven't been able to find a single VB implementation of Perlin Noise on the internet. So I guess if I can fix this one, it might help others. There seem to be alot of question about Perlin noise malfunction on StackOverflow
Public Class cdPerlinNoise
Private RandomGenerator As Random
Private BaseSeed As Integer
Private Persistence As Double
Private Frequency As Integer
Private Octaves As Integer
Public Sub New(tSeed As Integer, tPersistence As Double, tOctaves As Integer, tFrequency As Integer)
Frequency = tFrequency
BaseSeed = tSeed
Persistence = tPersistence
Octaves = tOctaves
End Sub
Private Function Noise(tX As Integer, tY As Integer) As Double
Dim tSeed As Integer
tSeed = WrapInteger(789221, BaseSeed, (tX * 1087) + (tY * 2749))
RandomGenerator = New Random(tSeed)
Return (RandomGenerator.Next(-10000, 10001) / 10000)
End Function
Private Function SmoothNoise(tX As Integer, tY As Integer) As Double
Dim Corners As Double = (Noise(tX - 1, tY - 1) + Noise(tX + 1, tY - 1) + Noise(tX - 1, tY + 1) + Noise(tX + 1, tY + 1)) / 16
Dim Sides As Double = (Noise(tX - 1, tY) + Noise(tX + 1, tY) + Noise(tX, tY - 1) + Noise(tX, tY + 1)) / 8
Return (Noise(tX, tY) / 4) + Corners + Sides
End Function
Private Function InterpolateCosine(tA As Double, tB As Double, tX As Double) As Double
Dim f As Double = (1 - Cos(tX * 3.1415927)) * 0.5
Return tA * (1 - f) + tB * f
End Function
Private Function Interpolate2D(tX As Double, tY As Double) As Double
Dim WholeX As Integer = CInt(Fix(tX))
Dim RemainsX As Double = tX - WholeX
Dim WholeY As Integer = CInt(Fix(tY))
Dim RemainsY As Double = tY - WholeY
Dim v1 As Double = SmoothNoise(WholeX, WholeY)
Dim v2 As Double = SmoothNoise(WholeX + 1, WholeY)
Dim v3 As Double = SmoothNoise(WholeX, WholeY + 1)
Dim v4 As Double = SmoothNoise(WholeX + 1, WholeY + 1)
Dim i1 As Double = InterpolateCosine(v1, v2, RemainsX)
Dim i2 As Double = InterpolateCosine(v3, v4, RemainsX)
Return InterpolateCosine(i1, i2, RemainsY)
End Function
Public Function PerlinValue(tX As Double, tY As Double) As Double
Dim Total As Double = 0
Dim Frequency As Double
Dim Amplitude As Double
For i = 0 To Octaves - 1
Frequency = Frequency ^ i
Amplitude = Persistence ^ i
Total = Total + (Interpolate2D(tX * Frequency, tY * Frequency) * Amplitude)
Next
Return Total
End Function
Public Function ScaleNoise(ByVal tX As Double, ByVal tY As Double, ByVal OutputLow As Double, ByVal OutputHigh As Double) As Double
Dim Range1 As Double
Dim Range2 As Double
Dim Result As Double
Range1 = 1 - -1
Range2 = OutputHigh - OutputLow
'(B*C - A*D)/R1 + n1*(R2/R1)
Result = (((1 * OutputLow) - (-1 * OutputHigh)) / Range1) + ((PerlinValue(tX, tY) * (Range2 / Range1)))
If Result < OutputLow Then
Return OutputLow
ElseIf Result > OutputHigh Then
Return OutputHigh
Else
Return Result
End If
End Function
End Class