'this goes at TOP of module before any procedures
Option Explicit
Private List() As Variant, Pairs() As Double
Const Limit As Long = 1000000
Private PairCount As Long, ResultsCount As Long, LimitCount As Long
Dim Results As Worksheet, Data As Worksheet, t As Double
'procedures
Sub Strat919_Version2()
t = Timer
Application.ScreenUpdating = False
ResultsCount = InputBox("How many items to output ?", "User choice", 100)
Call GeneratePairs
Call GenerateResults
MsgBox "Running time " & vbCr & Round((Timer - t) / 60, 1) & " minutes"
End Sub
Private Sub GeneratePairs()
Dim a As Long, b As Long, c As Long, r As Long
Set Data = ActiveSheet
[I][COLOR=#006400]'[/COLOR][COLOR=#ff0000]remove duplicate co-ordinates [/COLOR][COLOR=#006400]and place remaining values in array[/COLOR][/I]
Data.Range("A:B").RemoveDuplicates Columns:=Array(1, 2)
List = Data.Range("A1", Data.Range("A" & Data.Rows.Count).End(xlUp)).Resize(, 2)
PairCount = (UBound(List) ^ 2 - UBound(List)) / 2
ReDim Pairs(1 To PairCount, 1 To 4)
[COLOR=#006400][I]'place paired values in array[/I][/COLOR]
For a = 1 To UBound(List)
For b = 1 To UBound(List)
If b < a Then
r = r + 1
Pairs(r, 1) = List(a, 1)
Pairs(r, 2) = List(a, 2)
Pairs(r, 3) = List(b, 1)
Pairs(r, 4) = List(b, 2)
End If
Next b
Next a
End Sub
Private Sub GenerateResults()
Dim r2 As Long, r1 As Long, c As Long, Remainder As Long
[I][COLOR=#006400]'insert new worksheet[/COLOR][/I]
Set Results = Sheets.Add(before:=Sheets(1))
Results.Name = "Results " & Format(Now, "yymmdd h.mm am/pm")
[I][COLOR=#006400]'how many times to move subsets of values?, how many items in last subset?[/COLOR][/I]
LimitCount = WorksheetFunction.RoundDown(PairCount / Limit, 0)
Remainder = PairCount Mod Limit
[COLOR=#006400][I]'move each subset in sequence[/I][/COLOR]
r1 = 1
For c = 1 To LimitCount
r2 = r2 + Limit
Call MoveSubset(r1, r2)
r1 = r1 + Limit
Next c
If Remainder > 0 Then
r2 = r2 + Remainder
Call MoveSubset(r1, r2)
End If
End Sub
Private Sub MoveSubset(firstItem As Long, lastItem As Long)
Dim rTemp As Long, r As Long, c As Long, tempArr()
[COLOR=#ff0000]Const f[/COLOR] = "= 6371 * ACOS(COS(RADIANS(90 - A1)) * COS(RADIANS(90 -C1)) + SIN(RADIANS(90 - A1)) * SIN(RADIANS(90 - C1)) * COS(RADIANS(B1 -D1))) / 1.609"
ReDim tempArr(1 To lastItem - firstItem + 1, 1 To 4)
[I][COLOR=#006400]'move to temp array[/COLOR][/I]
For r = firstItem To lastItem
rTemp = rTemp + 1
For c = 1 To 4
tempArr(rTemp, c) = Pairs(r, c)
Next c
Next r
[I][COLOR=#006400]'create space for new rows[/COLOR][/I]
Results.Rows("1").Resize(UBound(tempArr)).Insert Shift:=xlDown
[COLOR=#006400][I]'write to worksheet and[/I][/COLOR][COLOR=#ff0000][I] calculate distances[/I][/COLOR]
With Results.Range("E1").Resize(UBound(tempArr))
.Offset(, -4).Resize(, 4).Value = tempArr
.Formula = f
.Value = .Value
End With
[COLOR=#006400]'sort and clear values not required[/COLOR]
Results.Range("A:E").Sort Key1:=Results.Range("E1"), Order1:=xlAscending, Header:=xlNo
Results.Range("A1").Offset(ResultsCount).Resize(Limit, 5).ClearContents
End Sub
