VBA/Excel: Conversions for longitude, latitide and UTM

I wrote a cute little Excel/VBA macro to convert common longitude or latitude notation into decimal degrees. Decimal degrees are useful for calculations and for converting into other formats, such as UTM. It accepts all common long/lat notation formats, such as decimal degrees, degree-minute and degree-minute-second. A negative decimal degree is the southern or western hemisphere (depending if it's longitude or latitude), by convention.

I've used the regular expression VB library, though this could easily be converted to simply do string searches using
. I just enjoy RegExes, for some reason. :3

To use regexes, you must have a reference to the regex library in your project. Open up the macro editor in Excel. Go Tools -> References... and put a check next to "Microsoft VBScript Regular Expressions 5.5", if it isn't already checked off.

Convert from string input to decimal degrees:

It's actually pretty simple to convert from a string coordinate notation to decimal degrees. The hard part is figuring out which format the user input.
In a module:

'-----Convert a string of common Long/lat notation into long/lat decimal degrees.
'-----Returns a double if a valid conversion was found, and Null otherwise to
'-----avoid using a specific number for error code.
'-----Accepts decimal degrees, degree-decimal hour, degree-hour-decimal min, degree-hour-min-decimal second

Public Function LonLatDecimal(userInput As String) As Variant
    Dim objRegExp As RegExp
    Dim tempstring As String
    Dim holderstring() As String
    Dim isNegative As Boolean
    Dim retVal As Double
    '---Create a regular expression object. Set properties
    Set objRegExp = New RegExp
    objRegExp.IgnoreCase = True
    objRegExp.Global = True 'Makes it search the whole string, instead of stopping at the first occurance
    '---remove everything that's not necessary punctuation or a number
    objRegExp.Pattern = "[^\d .]"
    If (objRegExp.test(userInput) = True) Then
        'replace all other punctuations with a space
        tempstring = objRegExp.Replace(userInput, " ")
        'No punctuation or letters...
        'Have to do this if-else 'cus replace will error if there's nothing to replace
        tempstring = userInput
    End If
    '---trim spaces down to only one space width, and split the string on that.
    objRegExp.Pattern = "( ){2,}"
    tempstring = objRegExp.Replace(tempstring, " ")
    Trim (tempstring) 'Remove both trailing and leading spaces
    holderstring = Split(tempstring, " ") 'Create array containing only the numeric values
    '---Figure out what kind of format we have based on the number of numric values we were given
    Select Case UBound(holderstring) - LBound(holderstring) + 1
        Case 1 'One number: means it's already in decimal degrees format
            retVal = Val(holderstring(0))

        Case 2 'two numbers: means it's in degree-decimal minute format
            retVal = Val(holderstring(0)) + Val(holderstring(1)) / 60

        Case 3 'Is in DMS format
            retVal = Val(holderstring(0)) + (Val(holderstring(1)) / 60) + (Val(holderstring(2)) / 3600)
        Case Else
            '---Some weird format, so we return "Null" as allowed by Variant
            '---Without Varient type, could return a value > 360
            LonLatDecimal = Null
            Exit Function
    End Select
    '---Test for if it should be negative
    objRegExp.Pattern = "[SW-]" 'Southern or western hemisphere; negative
    objRegExp.Global = False 'Only care about first instance.
    If (objRegExp.test(userInput) = True) Then
        retVal = -retVal
    End If
    LonLatDecimal = retVal
End Function

My implementation of the actual Macro. To use it, highlight columns of lats and/or longs in string formats. The macro will convert all valid inputs into decimal degrees and fill the columns to the selection's right, in the same order as was initially given. For example, if you highlight a column of latitudes and a column of longitudes, the column to the right will be filled with decimal degrees for the latitudes and the next column will have the decimal degrees for the longitudes.

If the current selection isn't a range (for example, if it is a chart or a shape) the macro will exit and error. If there is data in the cells to be written to, the macro will give the option to cancel or overwite.

In a module:
Public Sub ConvertLatLongToDecimal()
    Dim commons As Range
    Dim CommonCell As Range
    Dim DecimalVersion As Double
    Dim numCols As Integer
    Dim test As Integer
    '---Make sure we actually have cells selected and not some other object
    If Not TypeName(Selection) = "Range" Then
        MsgBox ("Please select a valid range of latitudes or longitudes")
        Exit Sub
    End If
    Set commons = Selection.Cells
    numCols = commons.Columns.Count
    '---Check that we have enough blank colums to the right of the selection
    If WorksheetFunction.CountA(Range(commons.Offset(0, numCols), commons.Offset(0, 2 * numCols))) <> 0 Then
        '--- Columns aren't blank, check that the user wants to overwrite them
        test = MsgBox("Data detected in target columns. Click 'OK' to continue and replace or 'Cancel' to quit.", _
        If test = vbCancel Then
            Exit Sub
        End If
    End If
    '---Iterate though all the cells and convert them
    For Each CommonCell In commons.Cells
        If Not IsEmpty(CommonCell) Then 'the value of an empty cell is "0" so we have to test here otherwise the decimal converter would let it pass through
            '---Note: lonlatdecimal returns null on no match. If we set a cell value equal to null, it stays blank. Convienent!
            Cells(CommonCell.Row, CommonCell.Column + numCols).value = LonLatDecimal(CommonCell.value)
            Cells(CommonCell.Row, CommonCell.Column + numCols).NumberFormat = "#.00000"
        End If

End Sub

Just for fun, here are some of the RegExes I wrote for catching certain coordinate formats. I haven't extensively tested them, but they worked for the testing I did. In the end I went with the simpler implementation above because it was simple enough to assume that decimal degrees will only have one number, degree-minute will have two and degree-minute-second will have three. I had no need to validate the format.

Decimal degrees:



Decimal degrees to UTM

To convert from decimal degrees to UTM I adapted a routine from what I have sourced as here, but the page seems to have been taken down.

It returns a class object I named UTMcoord, which simply holds a triplet for the Northing, Easting and Zone. One could implement this with a three-element array or (though I don't know why) a String. I chose to make a class object just for fun and so it would be more explicitly obvious what the values stood for.

In a class module "UTMCoord" :
'----- A class object to hold UTM coordinate values

Private pZone As Integer
Private pNorthing As Double
Private pEasting As Double

Public Property Get Zone() As Integer
    Zone = pZone
End Property

Public Property Let Zone(value As Integer)
    pZone = value
End Property

Public Property Get Northing() As Double
    Northing = pNorthing
End Property

Public Property Let Northing(value As Double)
    pNorthing = value
End Property

Public Property Get Easting() As Double
    Easting = pEasting
End Property

Public Property Let Easting(value As Double)
    pEasting = value
End Property

And the conversion routine, in a module:
' Lat/lon to UTM conversion functions
' By José Luis Esteban, December/99
' Adapted from http://www.anzlic.org.au/icsm/gdatm/chapter5.htm
' Slightly modified by Nano, http://philenotfound.blogspot.com/

' Some constants. Uses NAD83/WGS84 for UTM datums
Const SemiMajorAxis As Double = 6378137
Const InverseFlattening As Double = 298.257222101
Const Flattening As Double = 1 / InverseFlattening
Const Eccent2 As Double = 2 * Flattening - (Flattening * Flattening)
Const Eccent4 As Double = Eccent2 * Eccent2
Const Eccent6 As Double = Eccent2 * Eccent4
Const A0 As Double = 1 - (Eccent2 / 4) - ((3 * Eccent4) / 64) - ((5 * Eccent6) / 256)
Const A2 As Double = (3 / 8) * (Eccent2 + (Eccent4 / 4) + ((15 * Eccent6) / 128))
Const A4 As Double = (15 / 256) * (Eccent4 + ((3 * Eccent6) / 4))
Const A6 As Double = (35 * Eccent6) / 3072
Const FalseEasting = 500000 'adjusts to keep UTM coords from going negative
Const FalseNorthing = 0 'false Northing of 10 000 000 for southern hemisphere only
Const CentralScaleFactor As Double = 0.9996
Const ZoneWidth = 6
Const Zone1CentralMeridian = -177
Const Zone0WestMeridian = Zone1CentralMeridian - (1.5 * ZoneWidth)
Const Zone0CentralMeridian = Zone0WestMeridian + ZoneWidth / 2

' Function UTM - Calculates UTM coordinates UTM from Latitude and Longitude
' Parameters:
'     lat - latitude in sexagesimal degrees with decimals. North is positive
'     lon - longitude in sexagesimal degrees with decimals. East is positive

Function UTM(Lat, Lon) As UTMCoord
    ' Variables
    Dim LatRad, LonRad As Double
    Dim Sin1Lat, Sin2Lat, Sin4Lat, Sin6Lat As Double
    Dim DistOverMeridian As Double
    Dim Rho, Nu, Psi, Psi2, Psi3, Psi4 As Double
    Dim CosLat, CosLat2, CosLat3, CosLat4, CosLat5, CosLat6, CosLat7 As Double
    Dim TanLat, TanLat2, TanLat4, TanLat6 As Double
    Dim DifLon, DifLon2, DifLon3, DifLon4, DifLon5, DifLon6, DifLon7, DifLon8 As Double
    Dim Zone As Integer
    Dim CentralMeridian As Integer
    Dim East1, East2, East3, East4 As Double
    Dim North1, North2, North3, North4 As Double
    Dim X, Y As Double

    Dim retVal As UTMCoord
    Set retVal = New UTMCoord
    ' Parameters to radians
    LatRad = Lat / 180 * Application.WorksheetFunction.Pi
    LonRad = Lon / 180 * Application.WorksheetFunction.Pi

    Zone = Int((Lon - Zone0WestMeridian) / ZoneWidth)

    'Sin of latitude and its multiples
    Sin1Lat = Sin(LatRad)
    Sin2Lat = Sin(2 * LatRad)
    Sin4Lat = Sin(4 * LatRad)
    Sin6Lat = Sin(6 * LatRad)

    'Meridian Distance
    DistOverMeridian = SemiMajorAxis * (A0 * LatRad - A2 * Sin2Lat + A4 * Sin4Lat - A6 * Sin6Lat)

    'Radii of Curvature
    Rho = SemiMajorAxis * (1 - Eccent2) / (1 - (Eccent2 * Sin1Lat * Sin1Lat)) ^ 1.5
    Nu = SemiMajorAxis / (1 - (Eccent2 * Sin1Lat * Sin1Lat)) ^ 0.5
    Psi = Nu / Rho
    Psi2 = Psi * Psi
    Psi3 = Psi * Psi2
    Psi4 = Psi * Psi3

    'Powers of cos latitude
    CosLat = Cos(LatRad)
    CosLat2 = CosLat * CosLat
    CosLat3 = CosLat * CosLat2
    CosLat4 = CosLat * CosLat3
    CosLat5 = CosLat * CosLat4
    CosLat6 = CosLat * CosLat5
    CosLat7 = CosLat * CosLat6

    'Powers of tan latitude
    TanLat = Tan(LatRad)
    TanLat2 = TanLat * TanLat
    TanLat4 = TanLat2 * TanLat2
    TanLat6 = TanLat2 * TanLat4

    'Differences in longitude and its powers
    CentralMeridian = (Zone * ZoneWidth) + Zone0CentralMeridian
    DifLon = (Lon - CentralMeridian) / 180 * Application.WorksheetFunction.Pi
    DifLon2 = DifLon * DifLon
    DifLon3 = DifLon * DifLon2
    DifLon4 = DifLon * DifLon3
    DifLon5 = DifLon * DifLon4
    DifLon6 = DifLon * DifLon5
    DifLon7 = DifLon * DifLon6
    DifLon8 = DifLon * DifLon7

    'X (Easting)
    East1 = DifLon * CosLat
    East2 = DifLon3 * CosLat3 * (Psi - TanLat2) / 6
    East3 = DifLon5 * CosLat5 * (4 * Psi3 * (1 - 6 * TanLat2) + Psi2 * (1 + 8 * TanLat2) - Psi * (2 * TanLat2) + TanLat4) / 120
    East4 = DifLon7 * CosLat7 * (61 - 479 * TanLat2 + 179 * TanLat4 - TanLat6) / 5040
    X = CentralScaleFactor * Nu * (East1 + East2 + East3 + East4) + FalseEasting

    'Y (Northing)
    North1 = Sin1Lat * DifLon2 * CosLat / 2
    North2 = Sin1Lat * DifLon4 * CosLat3 * (4 * Psi2 + Psi - TanLat2) / 24
    North3 = Sin1Lat * DifLon6 * CosLat5 * (8 * Psi4 * (11 - 24 * TanLat2) - 28 * Psi3 * (1 - 6 * TanLat2) + Psi2 * (1 - 32 * TanLat2) - Psi * (2 * TanLat2) + TanLat4) / 720
    North4 = Sin1Lat * DifLon8 * CosLat7 * (1385 - 3111 * TanLat2 + 543 * TanLat4 - TanLat6) / 40320
    Y = CentralScaleFactor * (DistOverMeridian + Nu * (North1 + North2 + North3 + North4)) + FalseNorthing

    ' UTM return value
    retVal.Zone = Zone
    retVal.Easting = X
    retVal.Northing = Y
    Set UTM = retVal

End Function

My implementation for the actual macro, placed in a module. To run it from Excel, highlight two columns of coordinates, with latitude on the left and longitude on the right. To will convert all valid pairs (skipping blank lines, pairs with text or a missing lat/long) and fill in the three columns to the right as Northing, Easting and Zone.
Will exit and give a warning if more or less than two colums are selected or if the selection isn't a Range.
Will behave unexpectedly if given values that are not decimal degrees.

Public Sub ConvertLatLongToUTM()
    Dim latss As Range
    Dim latCell As Range
    Dim UTMPair As UTMCoord
    Dim test As Integer
    '---Make sure we actually have cells selected and not some other object
    If Not TypeName(Selection) = "Range" Then
        MsgBox ("Please select a valid range of latitude and longitude pairs")
        Exit Sub
    End If

    '---For now, we will only process data if it is in two colums:
    '---one for Long and one for Lat
    '---Seperated out of the previous "If" because VBA doesn't short circut
    If Selection.Columns.Count <> 2 Then
        MsgBox ("Please select a valid range of latitude and longitude pairs")
        Exit Sub
    End If
    '---The following needs 5 columns avaliable in this order:
    '--- Latitude values
    '--- Longitude values
    '--- Northing result
    '--- Easting result
    '--- Zone result
    Set lats = Selection.Columns(1)
    '---Check that we have three blank columns
    If WorksheetFunction.CountA(Range(lats.Offset(0, 2), lats.Offset(0, 4))) <> 0 Then
        '--- Columns aren't blank, check that the user wants to overwrite them
        test = MsgBox("Data detected in target columns. Click 'OK' to replace with UTM coordinates or 'Cancel' to quit.", _
        If test = vbCancel Then
            Exit Sub
        End If
    End If
    '---Iterate though the first column of the selection (set to variable lats)
    For Each latCell In lats.Cells
        '--- Check that it is a valid number
        '---Too bad VB doesn't short circuit, eh?
        If IsNumeric(latCell.value) And IsNumeric(latCell.Offset(0, 1).value) _
            And Not IsEmpty(latCell) And Not IsEmpty(latCell.Offset(0, 1)) Then
            '---Calculate the value
            Set UTMPair = UTM(latCell.value, latCell.Offset(0, 1).value)
            '---write to sheet (inefficiently, but speed isn't necessary here)
            latCell.Offset(0, 2).value = UTMPair.Northing
            latCell.Offset(0, 3).value = UTMPair.Easting
            latCell.Offset(0, 4).value = UTMPair.Zone
        End If
End Sub

I aimed to make this quick and easy to use and for it to be flexible. I've used it twice - once as a standalone macro, and once to validate user input to a form and convert to decimal degrees for further manipulation. Employees where I worked were quite pleased and impressed; I think it had never occurred to them they could automate the conversion process.

11 things about

VBA/Excel: Conversions for longitude, latitide and UTM
  1. Thanks for the precious knowledge.

  2. This was precisely the procedure I was looking for. I'm a Geo Cacher and will use this for solving puzzles! Really super!

    Greetings from Delft, The Netherlands,
    Leo Meijer

  3. I really like your decimal degrees to UTM instructions. I found the reposted GDA Technical manual, which is what the comments try to link to. The conversion algorithm is in chapter 5: http://www.icsm.gov.au/gda/gdav2.3.pdf

    Also, any idea who José Luis Esteban is? I couldn't find anything on him except where he posted the same script in an old forum.

    1. I'm afraid i don't know anything about him, just that he was the original author of the routine i used as a starting point.

    2. Hi!
      That's the only piece of code I've ever written in Visual Basic.

  4. This comment has been removed by the author.

    1. This comment has been removed by the author.

  5. This comment has been removed by the author.

  6. any tips on doing the reverse? (UTM to decimal degrees?)


Copyright 2012 Phile not Found. See About
Powered by Blogger

"Whenever you find that you are on the side of the majority, it is time to pause and reflect."