I am writing a VBA script that finds ZIP Codes inside of a specified radius. I have an Access Database with multiple records in a table. Each record has a Name, Address, and Zip Code field on the table. The VBA code on access prompts the user for a zip code and search radius then calculates the distance between the user input zip code and the zip code for each record. Once each distance is calculated the record is displayed to the form as long as it falls within the radius input field.
The code that I have written works but the execution time takes too long (around 30 secs for 2000ish records). How can I decrease the time it takes for this VBA code to run? Here is the code I have written:
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
I just did a test with a table of 1,976 restaurant locations:
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
...
Using the GreatCircleDistance function available from ...
http://www.cpearson.com/excel/LatLong.aspx
... I ran the following query to calculate the distance from a given point
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;
and the results came back in less than a second.
Then to return results within a certain number of kilometers from a given point I used
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];
and again, the results came back in less than a second.
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With