2个坐标之间的距离为2D阵列

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.

我有一个唯一的标识符(A列)及其各自的坐标集(DD单位,例如59,-110),用于500多个位置,并且想要编写一个创建2D阵列(500 + X 500+)的宏和使用数据集中所有其他坐标之间的距离自动填充数组中的每个单元格。

Sample Data set (starting in A1):

样本数据集(从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

提前致谢

1 个解决方案

#1

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

我有一些问题,Acos功能不起作用,所以我按照我的方式,从头开始,按照这里找到的公式

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

距离=(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))

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

It takes data in Sheet1 and outputs the matrix in Sheet2

它接受Sheet1中的数据并输出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.

在这里A和B之间进行的快速测试显示,这个结果几乎完全相同:该站点给出310.94 KM,我的功能给出310,9566251,这是+/- 15 cm的差异。超过300公里,这是可以接受的。

I can thus safely assume that it works.

因此,我可以安全地假设它有效。

Now you can tweak it ;)

现在你可以调整它;)

#1