Wednesday, June 20, 2012

VBA distance via Lat/Long

This code takes latitude and longitude of 2 locations and gets the distance in miles or kilometers, this is 'as the crow flies, not driving distance
I will try to edit when I find the calculations, but you can cut processing time dramatically (7 fold reduction if I recall) by subtracting lat 1 from lat 2 and long 1 from long 2, more than 1 is greater than 125 miles (will get exact numbers soon)

Place in a module to use as a function in a formula, or call directly via code
I got this online several years ago and unfortunately can't find the link and can't give credit
Private Const C_RADIUS_EARTH_KM As Double = 6370.97327862
Private Const C_RADIUS_EARTH_MI As Double = 3958.73926185

Private Const C_PI As Double = 3.14159265358979
Function GreatCircleDistance(Latitude1 As Double, Longitude1 As Double, _
Latitude2 As Double, Longitude2 As Double, _
ValuesAsDecimalDegrees As Boolean, _
ResultAsMiles As Boolean) As Double

Dim Lat1 As Double
Dim Lat2 As Double
Dim Long1 As Double
Dim Long2 As Double
Dim X As Long
Dim Delta As Double

If ValuesAsDecimalDegrees = True Then
X = 1
Else
X = 24
End If
' convert to decimal degrees

Lat1 = Latitude1 * X
Long1 = Longitude1 * X
Lat2 = Latitude2 * X
Long2 = Longitude2 * X

' convert to radians: radians = (degrees/180) * PI

Lat1 = (Lat1 / 180) * C_PI
Lat2 = (Lat2 / 180) * C_PI
Long1 = (Long1 / 180) * C_PI
Long2 = (Long2 / 180) * C_PI

' get the central spherical angle

Delta = ((2 * ArcSin(Sqr((Sin((Lat1 - Lat2) / 2) ^ 2) + _
Cos(Lat1) * Cos(Lat2) * (Sin((Long1 - Long2) / 2) ^ 2)))))

If ResultAsMiles = True Then

GreatCircleDistance = Delta * C_RADIUS_EARTH_MI

Else

GreatCircleDistance = Delta * C_RADIUS_EARTH_KM

End If
End Function
Function ArcSin(X As Double) As Double
' VBA doesn't have an ArcSin function. Improvise.
ArcSin = Atn(X / Sqr(-X * X + 1))
End Function

VBA multiple cells static reference

Credit http://www.ozgrid.com/forum/showthread.php?t=86661
'Select a range of sells and run, it will make all cell references static

Sub CycleAbsRel()

Dim inRange As Range, oneCell As Range
Static absRelMode As Long
absRelMode = (absRelMode Mod 4) + 1
Set inRange = Selection.SpecialCells(xlCellTypeFormulas)
If Not (inRange Is Nothing) Then
For Each oneCell In inRange
With oneCell
.FormulaR1C1 = Application.ConvertFormula(.FormulaR1C1, xlR1C1, xlR1C1, absRelMode, oneCell)
End With
Next oneCell
End If
End Sub