2个坐标二维数组之间的距离

Question

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

样本数据集（从 A1 开始）：

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

希望我可以创建一个如下所示的数组：

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

计算两个坐标之间距离的公式是：

=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

除此之外，如果可能的话，我想在数组的末尾添加一行，计算出的最小距离不为零。

这是我目前所拥有的：

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

对此的任何帮助将不胜感激

新的堆栈，如果需要任何其他信息，请询问

提前致谢

Answer 1

我遇到了Acos 函数无法正常工作的问题，所以我按照自己的方式从头开始，并遵循找到here 的公式

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

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

在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

结果：

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

在 A 和 B 之间完成 here 的快速测试表明结果几乎相同：该站点给出了 310.94 KM，而我的函数给出了 310,9566251，相差 +/- 15 厘米。超过 300 公里，这是可以接受的。

因此我可以放心地假设它有效。

现在你可以调整它了；）