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

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

它在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公里，可以接受。

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

现在你可以调整它了;)

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

Distance between 2 coordinates 2D array

excel

vba

ms-office