Question

我有一个唯一的标识符（A列）及其各自的坐标集（DD单位，例如59，-110），用于500多个位置，并且想要编写一个创建2D阵列的宏（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

我遇到了MyClass[]功能不起作用的问题，所以我从头开始，按照找到的公式here

进行操作

距离=（罪（（Me.TxtEndLat * 3.14159265358979）/ 180））*   （罪恶（（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 * Distance + 1））+ 2   * Atn（1））

它需要Acos中的数据并输出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之间进行的快速测试here显示，结果几乎相同：网站提供A B C A 0 310,9566251 507,6414335 B 310,9566251 0 458,4126121 C 507,6414335 458,4126121 0，我的函数提供310.94 KM，这是+/-的差异15厘米。超过300公里，这是可以接受的。

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

现在你可以调整它;）

2个坐标之间的距离2D数组

1 个答案: