Distance between 2 coordinates 2D array

Question

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.

Sample Data set (starting in A1):

ID       Lat  Long    
A        59   -110    
B        58   -105    
C        62   -103

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.

This is what I have so far:

Const R2D As Double = (3.1459 / 180) 
Const MagicNumber As Long = 637100  
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



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


Rws = Cells(Rows, Count, "A").End(xlUp).Row - 1


Originals = Application.Transpose(Range(Cells(2, "B"), Cells(Rws, "C"))).Value
ReDim Distances(1 To Rws1, 1 To Rws)


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))


   If Results > MinDistance Then Distances(i, j) = Results

 Next j: Next i


Range("F1").Resize(Rws, Rws) = Distances

End Sub

Any help with this would be greatly appreciated

New to stack so if there's any additional information needed please ask

Thanks in advance

Answer 1

I had some issue with Acos function not working so I did it my way, from scratch and following a formula found here

Distance = (Sin((Me.TxtEndLat * 3.14159265358979) / 180)) * (Sin((Me.TxtStartLat * _ 3.14159265358979) / 180)) + (Cos((Me.TxtEndLat * 3.14159265358979) / 180)) * _ ((Cos((Me.TxtStartLat * 3.14159265358979) / 180))) * _ (Cos((Me.TxtStartLong - Me.TxtEndLong) * (3.14159265358979 / 180)))

Distance = 6371 * (Atn(-Distance / Sqr(-Distance * Distance + 1)) + 2 * Atn(1))

It takes data in Sheet1 and outputs the matrix in Sheet2

Option Explicit

Sub test()

    Dim sheetSource As Worksheet
    Dim sheetResults As Worksheet

    Dim intPos As Long
    Dim intMax As Long

    Dim i As Long
    Dim j As Long
    Dim strID As String

    Dim dblDistance As Double
    Dim dblTemp As Double

    Dim Lat1 As Double 
    Dim Lat2 As Double 
    Dim Long1 As Double 
    Dim Long2 As Double 

    Const PI As Double = 3.14159265358979

    Set sheetSource = ThisWorkbook.Sheets("Sheet1")
    Set sheetResults = ThisWorkbook.Sheets("Sheet2")

    intPos = 1

    ' 1 Build the matrix
    For i = 2 To sheetSource.Rows.Count

        strID = Trim(sheetSource.Cells(i, 1))

        If strID = "" Then Exit For

        intPos = intPos + 1

        sheetResults.Cells(intPos, 1) = strID
        sheetResults.Cells(1, intPos) = strID

    Next i

    intMax = intPos


    If intMax = 1 Then Exit Sub ' no data


    ' 2 : compute matrix
    For i = 2 To intMax 'looping on lines

        Lat1 = sheetSource.Cells(i, 2)
        Long1 = sheetSource.Cells(i, 3)

        For j = 2 To intMax 'looping on columns

            Lat2 = sheetSource.Cells(j, 2)
            Long2 = sheetSource.Cells(j, 3)

            ' Some hard trigonometry over here
            dblTemp = (Sin((Lat2 * PI) / 180)) * (Sin((Lat1 * PI) / 180)) + (Cos((Lat2 * PI) / 180)) * _
                      ((Cos((Lat1 * PI) / 180))) * (Cos((Long1 - Long2) * (PI / 180)))


            If dblTemp = 1 Then ' If 1, the 2 points are the same. Avoid a division by zero
                 sheetResults.Cells(i, j) = 0
            else
                 dblDistance = 6371 * (Atn(-dblTemp / Sqr(-dblTemp * dblTemp + 1)) + 2 * Atn(1))
                 sheetResults.Cells(i, j) = dblDistance
            End If

        Next j
    Next i


End Sub

Results :

        A             B             C           
A   0             310,9566251   507,6414335
B   310,9566251   0             458,4126121
C   507,6414335   458,4126121   0    

A quick test done here between A and B shows that the resut is almost identical : The site gives 310.94 KM and my function gives 310,9566251, which is a difference of +/- 15 cm. Over 300 km, that's acceptable.

I can thus safely assume that it works.

Now you can tweak it ;)