Distance between 2 locations 2D array

[cwassmuth]

I have a unique identifier (column A) with its respective set of coordinates (DD units, ex. 59, -110) for 500+ locations and would like to write a macro that creates a 2D array (500+ X 500+) and automatically populates each cell within the array with the distance between all of the other coordinates in the data set.

For example:
__Lat Long
A 59 -110
B 34 -90
C 78 -80

Hopefully I can create an array that looks like this:

__A B C
A 0 X Y
B X 0 Z
C Y Z 0

The formula to calculate the distance between the two coordinates is:

=ACOS( SIN(lat1*PI()/180)*SIN(lat2*PI()/180) + COS(lat1*PI()/180)*COS(lat2*PI()/180)*COS(long2*PI()/180-long1*PI()/180) ) * 6371000

In addition to this, if possible I would like to add a row onto the end of the array that gives the lowest distance calculated that is not zero.

It does not have to be a macro either, I just thought this may be the fastest most efficient way to accomplish this

Any help with this would be greatly appreciated

Thanks in advance

[SamT]

All this is off the top of my head with no help from Excel VBA, so there will be errors.

Next time, Copy a block of cells from the Sheet and paste them into your post, so we can just C&P them into a worksheet. I certainly won't look up a mess of location's Lats and Longs to make my own test data. They don't pay me.

This formula should be the same


Const R2D As Double = (Pi/190)
Constant MagicNumber as long = 637100 'Convert to... Feet? Miles? Centimeters? *Furlongs?

ACOS(SIN(lat1)*SIN(lat2)*PIRN^2) + COS(lat1)*COS(lat2)*COS(long2)*PIRN^3 _
-long1*PIRN)*MagicNumber



Const R2D As Double = (Pi/180) 'Declared here for speed
Const MagicNumber as long = 637100 'Don't want to declare them 2500 times

Sub MakeMatrix()

Dim Originals As Variant
Dim Distances As Variant
Dim Results As Double
Dim i as long, j as Long, k As long, l As long
Dim Rws As Long
Const Lat as Long = 1
Const Lon As Long = 2
Const MinDistance = 0.01 '*Furlongs ' Adjust as desired

'How many Rows
Rws = Cells(Rows,Count, "A").End(xlUp)).Row - 1 '-1 for header Row

'Set up the arrays
Originals = Application.Transpose(Range(Cells(2, "B"), Cells(Rws, "C"))).Value
Redim Distances(1 to Rws1, 1 to Rws)

'Step thru Originals one Row at a time.Twice
For i = LBound(Originals) to Ubound(Originals)
For j = LBound(Originals) to Ubound(Originals)
Results = GetDistance(Lat1:=Originals(i, Lat), _
Lat2 =Originals(j, Lat), _
Long1:=Originals(i, Lon), _
Long1:=Originals(j, Lon))
'Step thru Distances by columns then by rows
If Results > MinDistance Then Distances(i, j) = Results 'No zeros, so you can find the min()
'YOu might have to add 1 to i & j for the Distances array indices
Next j: Next i

'TBD: add Headers and Row Lables to Matrix
'You need to Assign Top left cell of Range for Matrix
Range("??").Resize(Rws, Rws) = Distances

End Sub

Private Function GetDistances(Lat1 As Double, Lat2 As Double, Long1 As Double, Long2 As Double) As Double

GetDistances = ACOS(SIN(lat1)*SIN(lat2)*R2D^2) + COS(lat1)*COS(lat2)*COS(long2)*R2D^3 _
-long1*R2D)*MagicNumber
End Function

[cwassmuth]

Thanks for the quick reply!

Here is a few of the values, sorry didn't post them before

22188

[Paul_Hossler]

There are efficiencies that can be added, but at the expense of increasing the complexity



Option Explicit

Sub MakeMatrix()

Dim rIn As Range
Dim wsOut As Worksheet
Dim i As Long, j As Long
Dim Lat1 As Double, Lat2 As Double, Long1 As Double, Long2 As Double

Set rIn = Worksheets("Sheet1").Cells(1, 1).CurrentRegion

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Matrix").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Worksheets.Add.Name = "Matrix"
Set wsOut = Worksheets("Matrix")


For i = 2 To rIn.Rows.Count
wsOut.Cells(i, 1).Value = rIn.Cells(i, 1).Value
wsOut.Cells(1, i).Value = rIn.Cells(i, 1).Value
Next i


For i = 2 To rIn.Rows.Count
For j = 2 To rIn.Rows.Count

Lat1 = rIn.Cells(i, 2).Value
Long1 = rIn.Cells(i, 3).Value
Lat2 = rIn.Cells(j, 2).Value
Long2 = rIn.Cells(j, 3).Value

If i = j Then
wsOut.Cells(i, j).Value = 0#
Else
With Application.WorksheetFunction
wsOut.Cells(i, j).Value = _
.Acos(Sin(Lat1 * .Pi / 180) * Sin(Lat2 * .Pi / 180) + Cos(Lat1 * .Pi / 180) * Cos(Lat2 * .Pi / 180) * Cos(Long2 * .Pi / 180 - Long1 * .Pi / 180)) * 6371000
End With
End If
Next j
Next i
End Sub