Distance between 2 locations 2D array

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

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

Code:

---


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

---

Code:

---

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

---

Code:

---

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

---

Thanks for the quick reply!

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

Attachment 22188

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

Code:

---

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

---