Question

我有一个复杂的问题，我已经工作了几个星期没有成功，任何和所有帮助都非常感谢。

我有2对经度和纬度的合作，

A1:A11418 = lat1  
B1:B11418 = long1  
C1:C11418 = lat1/long1 Corresponding ID to be returned  
D1:D10248 = lat2  
E1:E10248 = long2
F1:F10248 = Return column for ID

D列，E列的顺序与A，B完全不同。
我需要将lat / long1与lat / long2进行匹配并比较它之间的距离，如果它是＆lt; =所需的距离，则只输出从C列到F的距离最小的ID。

Private Sub CommandButton1_click()

Dim ID As Double
Dim Dist, Results, Pre_rslt As Variant
Dim lat1, long1, lat2, long2 As Range
Dim i As Integer, j As Integer

j_DO:
Do While j <= 11418             '## lat/long1 (Col D, E) Counter
j = j + 1

i_DO:
    Do While i <= 10248         '## lat/long2 (Col A, B) Counter     
    i = i + 1

    Set lat1 = Range("A2").Offset(i)
    Set long1 = Range("B2").Offset(i)
    Set lat2 = Range("D2").Offset(j)
    Set long2 = Range("E2").Offset(j)

    If IsEmpty(Range("A2").Offset(i).Value) = True Or IsEmpty(Range("B2").Offset(i).Value) = True Then
        i = i + 1
    End If

        earth_radius = 6371    '## GCD START
        PI = 3.14159265
        deg2rad = PI / 180

        dLat = deg2rad * (lat2 - lat1)
        dLon = deg2rad * (long2 - long1)

        a = Sin(dLat / 2) * Sin(dLat / 2) + Cos(deg2rad * lat1) * Cos(deg2rad * lat2) * Sin(dLon / 2) * Sin(dLon / 2)
        c = 2 * WorksheetFunction.Asin(Sqr(a))

        d = earth_radius * c
        Dist = d               '## GCD END

        If Dist <= 1 Then            '## Result filtering
            Results = ID
            Cells(j, 6) = Results
            ID = Range("B2").Offset(i, 1)
            i = 0
            GoTo j_DO
        ElseIf i >= 10248 And Results <> ID Then
            i = 0
            GoTo j_DO
        ElseIf IsEmpty(Range("F2").Offset(j).Value) = True Then
            GoTo i_DO
        End If
    Loop
Loop

End Sub

就像现在一样，它将返回随机结果，我无法弄清楚如何让它只返回最接近的结果。

P.S请原谅我的代码/说明我只使用了VBA 2-3周，而且还很新，谢谢你的帮助。

Answer 1

更改了代码格式。这对我有用。

Sub CommandButton2_click()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim ID, Results As String
Dim Dist, dist_min As Double
Dim lat1, long1, lat2, long2, dLat, dLong As Double
Dim data1r, data2r As Integer

earth_radius = 6371 'km
Pi = 3.14159265
deg2rad = Pi / 180


For data2r = 2 To 75    '2nd set of lat/lon rows
    dist_min = 2 * earth_radius * Pi    'furthest point on earth
    Results = ""
    For data1r = 2 To 100   '1st set of lat/lon rows
        lat1 = Cells(data1r, 1)
        long1 = Cells(data1r, 2)
        ID = Cells(data1r, 3)
        lat2 = Cells(data2r, 4)
        long2 = Cells(data2r, 5)

        lat1 = lat1 * deg2rad
        long1 = long1 * deg2rad
        lat2 = lat2 * deg2rad
        long2 = long2 * deg2rad
        dLat = Abs(lat2 - lat1)
        dLong = Abs(long2 - long1)

        a = Sin(dLat / 2) ^ 2 + Cos(lat1) * Cos(lat2) * (Sin(dLong) ^ 2)
        c = 2 * WorksheetFunction.Atan2(a ^ 0.5, (1 - a) ^ 0.5)

        d = earth_radius * c
        Dist = d               '## GCD END

        If Dist < dist_min Then
            Results = ID
            dist_min = Dist
            lat = lat1
            lon = long1
        End If

    Next data1r
    Cells(data2r, 6) = Results
Next data2r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

比较2组纬度/长度，如果距离小于指定量，则返回相应的值

1 个答案: