excel vba中大型数据集中纬度/经度之间的最近距离

Question

初学者活套在这里......我正在研究这个井距项目，该项目查看纬度/经度并确定下一个最近的井。我想我可能正在创建一个无限循环，或者程序需要永远运行（它循环遍历 15,000 行）。我的主要努力是试图确保将每个位置与数据集中的每个位置进行比较。从那里我取第二低的距离（因为与自身相比，最低的距离为零）。

Sub WellSpacing()
Dim r As Integer, c As Integer, L As Integer, lastrow As Integer
Dim lat1 As Double, lat2 As Double, long1 As Double, long2 As Double
Dim distance As Double, d1 As Double, d2 As Double, d3 As Double
Dim PI As Double

PI = Application.WorksheetFunction.PI()
L = 2
r = 3
c = 10
lastrow = Sheets("Test").Cells(Rows.Count, "J").End(xlUp).Row

For L = 2 To lastrow
    For r = 2 To lastrow
        lat1 = Sheets("Test").Cells(L, c)
        long1 = Sheets("Test").Cells(L, c + 1)
        lat2 = Sheets("Test").Cells(r, c)
        long2 = Sheets("Test").Cells(r, c + 1)
        d1 = Sin((Abs((lat2 - lat1)) * PI / 180 / 2)) ^ 2 + Cos(lat1 * PI / 180) * Cos(lat2 * PI / 180) * Sin(Abs(long2 - long1) * PI / 180 / 2) ^ 2
        d2 = 2 * Application.WorksheetFunction.Atan2(Sqr(1 - d1), Sqr(d1))
        d3 = 6371 * d2 * 3280.84
        Sheets("Working").Cells(r - 1, c - 9) = d3
    Next r

    Sheet2.Activate
    Range("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending
    distance = Sheet2.Range("A2")
    Sheets("Test").Cells(L, c + 2) = distance
    Sheet2.Range("A:A").Clear
    Sheet1.Activate

Next L
End Sub

Answer 1

我建议使用数组，正如 @Qharr 所说。我还希望通过包含一些逻辑步骤来加快这一过程，以避免对每组点进行复杂的数学计算。

我的意思是，您可以先进行粗略估计，看看是否需要进行实际计算。我查看了当前位置的纬度或经度是否比最后一个最近的点更接近，但你可以做任何你想做的事情。

我会将您的代码更改为以下内容：

Sub WellSpacing()
    Dim R As Integer, C As Integer, L As Integer, LastRow As Integer, Shortest() As Integer
    Dim Lats() As Double, Longs() As Double, Distances() As Double
    Dim Distance As Double, D1 As Double, D2 As Double, D3 As Double
    Dim PI As Double

    On Error Resume Next
    PI = Application.WorksheetFunction.PI()
    L = 2
    R = 3
    C = 10
    LastRow = Sheets("Test").Cells(Rows.Count, 10).End(xlUp).Row
    ReDim Lats(1 To (LastRow - 1)) As Double
    ReDim Longs(1 To (LastRow - 1)) As Double
    ReDim Distances(1 To (LastRow - 1)) As Double
    ReDim Shortest(1 To (LastRow - 1)) As Integer

    For L = 2 To LastRow
        Lats(L - 1) = Sheets("Test").Range("J" & L).Value
        Longs(L - 1) = Sheets("Test").Range("K" & L).Value
    Next L

    For L = 1 To (LastRow - 1)
        'This is a method of setting an initial value that can't be obtained  through the caclucations (so you will know if any calcs have been done or not).
        Distances(L) = -1
        For R = 1 To (LastRow - 1)
            'This minimises your calculations by 15,000 to begin with
            If R = L Then GoTo Skip_This_R
            'This skips checking the previous distances if it is the first calculation being checked.
            If Distances(L) = -1 Then GoTo Skip_Check
            'If there has already been a distance calculated, this does a rough check of whether the Lat or Long is closer. If neither
            'the Lat or Long are closer than the current closest, then it will skip it. This reduces the code by 7 lines for most pairs.
            If Abs(Lats(L) - Lats(R)) < Abs(Lats(L) - Lats(Shortest(L))) Or Abs(Longs(L) - Longs(R)) < Abs(Longs(L) - Longs(Shortest(L))) Then
Skip_Check:
                    D1 = Sin((Abs((Lats(R) - Lats(L))) * PI / 180 / 2)) ^ 2 + Cos(Lats(L) * PI / 180) * Cos(Lats(R) * PI / 180) * Sin(Abs(Longs(R) - Longs(L)) * PI / 180 / 2) ^ 2
                    D2 = 2 * Application.WorksheetFunction.Atan2(Sqr(1 - D1), Sqr(D1))
                    D3 = 6371 * D2 * 3280.84
                    If D3 < Distances(L) Or Distances(L) = -1 Then
                            Distances(L) = D3
                            'This stores the index value in the array of the closest Lat/Long point so far.
                            Shortest(L) = R
                    End If
            End If
Skip_This_R:
        Next R
        'This puts the resulting closest distance into the corresponding cell.
        Sheets("Test").Range("L" & (L + 1)).Value = Distances(L)
        'This clears any previous comments on the cell.
        Sheets("Test").Range("L" & (L + 1)).Comments.Delete
        'This adds a nice comment to let you know which Lat/Long position it is closest to.
        Sheets("Test").Range("L" & (L + 1)).AddComment "Matched to Row " & (Shortest(L) + 1)
    Next L
End Sub