'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
Did you amend the size of array Pairs to match the increased number of items you were telling VBA to put inside it ?I tried to edit the code to remove the duplicate deletion, but always got errors....lol.
[COLOR=#000080]
For a = 1 To UBound(List)
For b = 1 To UBound(List)
Next b
Next a
[/COLOR]
PairCount = (UBound(List) ^ 2 - UBound(List)) / 2
PairCount = (UBound(List) * (UBound(List) + 1)) / 2
If b < a Then
If b <= a Then
The code is doing what I expected - it is now including all zero distancesYes.... Zero distances included in results shee
A | B | C | D | |
---|---|---|---|---|
1 | 51.5074 | 0.1278 | London | |
2 | 53.4808 | 2.2426 | Manchester | |
3 | 53.7676 | 0.3274 | Hull | |
4 | 51.4545 | 2.5879 | Bristol |
Sheet: Sheet1 |
A | B | C | D | E | F | G | |
---|---|---|---|---|---|---|---|
1 | 51.5074 | 0.1278 | 51.5074 | 0.1278 | 0.00 | London | London |
2 | 53.7676 | 0.3274 | 53.7676 | 0.3274 | 0.00 | Hull | Hull |
3 | 51.4545 | 2.5879 | 51.4545 | 2.5879 | 0.00 | Bristol | Bristol |
4 | 53.4808 | 2.2426 | 53.4808 | 2.2426 | 0.00 | Manchester | Manchester |
5 | 53.7676 | 0.3274 | 53.4808 | 2.2426 | 80.96 | Hull | Manchester |
6 | 51.4545 | 2.5879 | 51.5074 | 0.1278 | 105.94 | Bristol | London |
7 | 51.4545 | 2.5879 | 53.4808 | 2.2426 | 140.79 | Bristol | Manchester |
8 | 53.7676 | 0.3274 | 51.5074 | 0.1278 | 156.42 | Hull | London |
9 | 53.4808 | 2.2426 | 51.5074 | 0.1278 | 162.82 | Manchester | London |
10 | 51.4545 | 2.5879 | 53.7676 | 0.3274 | 185.86 | Bristol | Hull |
Sheet: Results 190727 6.32 am |