I've used the regular expression VB library, though this could easily be converted to simply do string searches using

likeand

replace. 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, " ") Else '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.", _ vbOKCancel) 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 Next 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:

^\s*[-+]?\s*\d+\.?\d*\s*°?[NESW]?\s*$

Decimal-minute:

^\s*[-+]?\s*\d+[°:]\s*\d+\.?\d*\s*'?\s*[NESW]?\s*$

Decimal-minute-seconds:

^\s*[-+]?\s*\d+[°:]?\s*\d+[':]?\s*\d+\.?\d*""?\s*[NESW]?

# 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 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.", _ vbOKCancel) 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 Next 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.

Thanks for the precious knowledge.

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

ReplyDeleteGreetings from Delft, The Netherlands,

Leo Meijer

Glad I could help, and good luck, Leo!

DeleteI 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

ReplyDeleteAlso, 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.

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.

DeleteThis comment has been removed by the author.

ReplyDeleteThis comment has been removed by the author.

DeleteThis comment has been removed by the author.

ReplyDeletegreat code, thanks Sam!

ReplyDeleteany tips on doing the reverse? (UTM to decimal degrees?)

ReplyDelete