GreatCircleDistanceStr.bas

gistfile1.txt

Option Explicit

' Great Circle Distance using the Haversine formula
' coord1 / coord2 are strings like: "27.9506, -82.4572"
' Unit: "km" (default), "mi", "nmi"
' Returns Double, or CVErr(xlErrValue) on invalid input.
Public Function GreatCircleDistanceStr( _
    ByVal coord1 As String, _
    ByVal coord2 As String, _
    Optional ByVal Unit As String = "km" _
) As Variant
    On Error GoTo SafeExit
    
    Dim Lat1 As Double, lon1 As Double
    Dim Lat2 As Double, lon2 As Double
    
    ' Parse both coordinate strings
    If Not ParseLatLon(coord1, Lat1, lon1) Then
        GreatCircleDistanceStr = CVErr(xlErrValue)
        Exit Function
    End If
    If Not ParseLatLon(coord2, Lat2, lon2) Then
        GreatCircleDistanceStr = CVErr(xlErrValue)
        Exit Function
    End If
    
    ' Validate latitude ranges
    If Abs(Lat1) > 90# Or Abs(Lat2) > 90# Then
        GreatCircleDistanceStr = CVErr(xlErrValue)
        Exit Function
    End If
    
    ' Normalize longitudes to [-180, 180)
    lon1 = NormalizeLongitude(lon1)
    lon2 = NormalizeLongitude(lon2)
    
    ' Convert degrees to radians
    Dim phi1 As Double, phi2 As Double, dPhi As Double, dLambda As Double
    phi1 = ToRadians(Lat1)
    phi2 = ToRadians(Lat2)
    dPhi = ToRadians(Lat2 - Lat1)
    dLambda = ToRadians(lon2 - lon1)
    
    ' Haversine
    Dim sinHalfDPhi As Double, sinHalfDLambda As Double, a As Double, c As Double
    sinHalfDPhi = Sin(dPhi / 2#)
    sinHalfDLambda = Sin(dLambda / 2#)
    a = sinHalfDPhi ^ 2 + Cos(phi1) * Cos(phi2) * sinHalfDLambda ^ 2
    
    ' Clamp to [0,1] to counter rounding noise
    If a < 0# Then a = 0#
    If a > 1# Then a = 1#
    
    c = 2# * Atn2(Sqr(a), Sqr(1# - a))   ' equivalent to 2*asin(sqrt(a))
    
    ' Earth radius by unit
    Dim R As Double
    Select Case LCase$(Trim$(Unit))
        Case "km", "kilometer", "kilometers"
            R = 6371.0088
        Case "mi", "mile", "miles"
            R = 3958.7613
        Case "nmi", "nm", "nauticalmile", "nauticalmiles"
            R = 3440.065
        Case Else
            R = 6371.0088  ' default km
    End Select
    
    GreatCircleDistanceStr = R * c
    Exit Function

SafeExit:
    If Err.Number <> 0 Then
        GreatCircleDistanceStr = CVErr(xlErrValue)
    End If
End Function

' --- Helpers ---

' Parse "lat, lon" string into doubles. Accepts extra spaces.
' Returns True on success, False on failure.
Private Function ParseLatLon(ByVal coord As String, ByRef lat As Double, ByRef lon As Double) As Boolean
    Dim parts() As String
    Dim cleaned As String
    
    cleaned = Trim$(coord)
    ' Allow a stray degree symbol; strip it if present
    cleaned = Replace(cleaned, "°", "")
    
    ' Split on comma
    parts = Split(cleaned, ",")
    If UBound(parts) <> 1 Then
        ParseLatLon = False
        Exit Function
    End If
    
    Dim sLat As String, sLon As String
    sLat = Trim$(parts(0))
    sLon = Trim$(parts(1))
    
    If Len(sLat) = 0 Or Len(sLon) = 0 Then
        ParseLatLon = False
        Exit Function
    End If
    
    ' Ensure numeric
    If Not IsNumeric(sLat) Or Not IsNumeric(sLon) Then
        ParseLatLon = False
        Exit Function
    End If
    
    lat = CDbl(sLat)
    lon = CDbl(sLon)
    ParseLatLon = True
End Function

' degrees ? radians
Private Function ToRadians(ByVal degrees As Double) As Double
    ToRadians = degrees * WorksheetFunction.Pi() / 180#
End Function

' Normalize longitude to [-180, 180)
Private Function NormalizeLongitude(ByVal lon As Double) As Double
    NormalizeLongitude = lon - 360# * WorksheetFunction.Floor_Math((lon + 180#) / 360#)
End Function

' Stable atan2(y, x) using VBA's Atn
Private Function Atn2(ByVal y As Double, ByVal X As Double) As Double
    If X > 0# Then
        Atn2 = Atn(y / X)
    ElseIf X < 0# Then
        Atn2 = Atn(y / X) + Sgn(y) * WorksheetFunction.Pi()
    Else
        If y > 0# Then
            Atn2 = WorksheetFunction.Pi() / 2#
        ElseIf y < 0# Then
            Atn2 = -WorksheetFunction.Pi() / 2#
        Else
            Atn2 = 0#
        End If
    End If
End Function