更快速地计算两个位置之间的距离(邮政编码)

Question

我正在编写一个VBA脚本,用于查找指定半径内的ZIP代码.我有一个Access数据库,在表中有多个记录.每个记录在表上都有一个名称,地址和邮政编码字段.上访问VBA代码提示输入邮政编码和搜索半径用户然后计算用户输入的邮政编码,每个记录的邮政编码之间的距离.计算每个距离后,只要记录落在半径输入字段内,记录就会显示在表格中.

我编写的代码有效但执行时间太长(2000年记录大约30秒).如何减少运行此VBA代码所需的时间？这是我写的代码:

Private Sub Command65_Click()
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim i, j As Integer
Dim db As Database
Dim rs As Recordset
Dim ZIP, r As Double
Dim arr(33144, 3) As Double
Dim lat1, long1, lat2, long2, theta As Double
Dim Distance As Integer
Dim deg2rad, rad2deg As Double
Const PI As Double = 3.14159265359
'Dim Variables

StartTime = Timer
deg2rad = PI / 180
rad2deg = 180 / PI

r = Text1.Value
ZIP = Text2.Value
'Get radius and prompted zip code from form

Set db = CurrentDb
Set rs = db.OpenRecordset("US Zip Codes")
'Open the Table named "US Zip Codes"

For i = 0 To 33143
    arr(i, 0) = rs.Fields("ZIP")
    arr(i, 1) = rs.Fields("LAT")
    arr(i, 2) = rs.Fields("LNG")
    rs.MoveNext
Next i
'Loop through each Zip Code record and store the Zip Code, Lattitude Point, and Longitude Point to an array

For i = 0 To 33143
    If ZIP = arr(i, 0) Then
        lat1 = arr(i, 1) * deg2rad
        long1 = arr(i, 2) * deg2rad
    End If
Next i
'Loop through the zip code array to get Zip Code's corresponding LAT and LONG

Set rs = db.OpenRecordset("Clinics")
'Open the Table named "Clinics"

For j = 0 To 2094
    If rs("Clinic ZIP") = ZIP Then
        Distance = 0
        'If Zip Code 1 and Zip Code 2 are equal to each other, Distance = 0
    ElseIf rs("Clinic ZIP") <> "" Then
        zip2 = rs("Clinic ZIP")
        For i = 0 To 33143
            If zip2 = arr(i, 0) Then
                lat2 = arr(i, 1) * deg2rad
                long2 = arr(i, 2) * deg2rad
            End If
        Next i
        'Loop through the zip code array to get the second Zip Code's corresponding LAT and LONG
        theta = long1 - long2
        Distance = ArcCOS(Sin(lat1) * Sin(lat2) + Cos(lat1) * Cos(lat2) * Cos(theta)) * rad2deg * 60 * 1.1515
        'Calculate Distance between the two zip codes
    Else
        Distance = 999
        'Set Arbitrary Value if the zip code field is empty
    End If
    rs.Edit
    rs.Fields("Distance") = Distance
    rs.Update
    rs.MoveNext
Next j

Me.Filter = "Distance<=" & r
Me.FilterOn = True
'Filter the table with calculated distance by prompted radius
Forms("Zip Search").Requery
rs.Close
Set rs = Nothing
db.Close

SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

Answer 1

我刚用1,976个餐厅位置进行了测试:

ID  lon        lat       poi_name                                     
--  ---------  --------  ---------------------------------------------
 1   -114.063   51.0466  Palomino Smokehouse: Calgary, AB             
 2   -114.055   51.0494  Bookers BBQ Grill and Crab Shack: Calgary, AB
 3  -86.97871  34.58037  Big Bob Gibson's Original: Decatur, AL       
 4  -87.01763  34.56587  Big Bob Gibson's #2: Decatur, AL             
 5    -86.364  32.26995  DJ's Old Post Office: Hope Hull, AL          
...

使用GreatCircleDistance...提供的功能

http://www.cpearson.com/excel/LatLong.aspx

...我运行以下查询来计算给定点的距离

PARAMETERS prmLon IEEEDouble, prmLat IEEEDouble;
SELECT BBQ2.ID, BBQ2.lon, BBQ2.lat, BBQ2.poi_name, 
    GreatCircleDistance([prmLat],[prmLon],[lat],[lon],True,False) AS km
FROM BBQ2;

结果在不到一秒钟内回归.

然后从我使用的给定点返回一定距离内的结果

PARAMETERS prmLon IEEEDouble, prmLat IEEEDouble, prmWithinKm IEEEDouble;
SELECT * FROM
(
    SELECT BBQ2.ID, BBQ2.lon, BBQ2.lat, BBQ2.poi_name, 
        GreatCircleDistance([prmLat],[prmLon],[lat],[lon],True,False) AS km
    FROM BBQ2
)
WHERE km <= [prmWithinKm];

再一次,结果在不到一秒钟内回归.