Sub array_distance_calc()
Dim WS As Worksheet
Dim Coordinates() As Variant
Dim FixedPoint(0 To 1) As Variant
Dim Distances() As Variant
Dim LastRow As Long
Dim C1 As Long
Dim i As Long
Set WS = Worksheets("calc distance")
FixedPoint(0) = Cells(2, 7).value 'fixed pt lat
FixedPoint(1) = Cells(2, 8).value 'fixed pt long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
'populate Coordinates array
Coordinates = Range("G6:H" & LastRow)
C1 = UBound(Coordinates, 1)
ReDim Preserve Distances(C1)
'Get Distance calculation starts
Dim n As Integer
Dim earthSphereRadiusNauticalMiles As Double
Dim kilometerConversionToMilesFactor As Double
Dim lat1Radians, lon1Radians, lat2Radians, lon2Radians As Double
Dim Lat1Degrees, Lat2Degrees, Lon1Degrees, Lon2Degrees As Double
Dim AsinBase As Double
Dim DerivedAsin As Double
Dim Min, Max As Integer
Dim FirstRow As Long
Application.DisplayAlerts = False
'Mean radius of the earth (replace with 3443.89849 to get nautical miles, 6371 to get KM)
FirstRow = 6
Min = Cells(4, 9).value
Max = Cells(4, 10).value
If Not IsNumeric(Cells(2, 7)) Then
MsgBox ("Input form incomplete. Query will be closed")
Exit Sub
End If
Lat1Degrees = FixedPoint(0) 'Cells(2, 7)
Lon1Degrees = FixedPoint(1) 'Cells(2, 8)
earthSphereRadiusNauticalMiles = 3443.89849
For i = 1 To C1 Step 1
Lat2Degrees = Coordinates(i, 1) 'Cells(n, 7)
Lon2Degrees = Coordinates(i, 2) 'Cells(n, 8)
'Convert each decimal degree to radians
lat1Radians = (Lat1Degrees / 180) * 3.14159265359
lon1Radians = (Lon1Degrees / 180) * 3.14159265359
lat2Radians = (Lat2Degrees / 180) * 3.14159265359
lon2Radians = (Lon2Degrees / 180) * 3.14159265359
AsinBase = Sin(Sqr(Sin((lat1Radians - lat2Radians) / 2) ^ 2 + Cos(lat1Radians) _
* Cos(lat2Radians) * Sin((lon1Radians - lon2Radians) / 2) ^ 2))
DerivedAsin = (AsinBase / Sqr(-AsinBase * AsinBase + 1))
'Get distance from [lat1,lon1] to [lat2,lon2]
Distances(i - 1) = Round(2 * DerivedAsin * earthSphereRadiusNauticalMiles, 0)
Next i
'final version requires calulated distance in col J
WS.Range("J6").Resize(UBound(Distances)).value = Application.Transpose(Distances)
'erase arrays
Erase Coordinates
Erase Distances
Erase FixedPoint
'delete rows outside specified distance range
Dim Z As Integer
For Z = LastRow To 6 Step -1
If Range("J" & Z) > Max Or Range("J" & Z) < Min Then
Rows(Z).Delete
End If
Next
Application.DisplayAlerts = True
End Sub