Should this code be written differently? Takes way longer than sorting each sheet manually

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,540
Office Version
365
Platform
Windows
Thanks for the info
- glad the code is doing what you want
- reckon I can speed it up slightly
- will update the thread later today after testing a few things
 
Last edited:

Some videos you may like

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

strat919

Board Regular
Joined
May 15, 2019
Messages
54
One other thing that may not be important. I wasn't sure if you wanted all the code put in one module or in 3 separate modules.

I put them all in one module and got errors. I put them in 3 separate modules and ran perfect. Don't know if that would have anything to do with speed.

If it was to go into one module, maybe I did something wrong. Putting them in 3 modules, one macro shows up.....strat919.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,540
Office Version
365
Platform
Windows
Try this version
- it should be considerable faster
- duplicate co-ordinates are removed at the outset
- array is now reduced to 4 columns (ie a pair of co-ordinates without distances
- distances are now calculated in the worksheet by formula and immediately overwritten with the value


Use a NEW workbook
EVERYTHING goes in ONE module

Code:
'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
 
Last edited:

strat919

Board Regular
Joined
May 15, 2019
Messages
54
It dramatically reduced the time!

4500 entries was 5 min. initially, 3.5 min. with your version1 and 1.5 min. with version2

12,500 entries was 24 min. version1 and now only 7.6 min with version2

Only thing I see that needs to be changed is exact duplicates ( 0 in the distance column) need to be included in distance list. In version1 they showed up. There would never be a case where 2 users would add the exact coordinates... but if a single user were to think he didn't enter it correctly or that his coordinates weren't added in time... he may add the same coordinates a second time. So I need to be able to see the the 0 distances also.

Something I'm not sure of. The way I had intended to run the macro.... open the blank workbook with the code, copy all coordinates from the running coordinate master.
Then run the macro and see if I need to contend with any duplicates coordinates. Delete them out of the master list, save, and then close the workbook with your code without saving. I am not running your code in the master as there are many other columns of info. Then run your code once a week when I update the master with new coordinates. I don't know if you assumed that I would be saving the workbook with your code each time, adding the newest coordinates, and somehow your code knows what has already been compared and only compares the new coordinates that I have added. I don't think this is the case.... but not positive.

Hope all that makes sense:)

For anybody else who produced some code in the Yongle code.... that has helped me out, thank you also:)
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,540
Office Version
365
Platform
Windows
What the code does
1. Removes duplicate co-ordinates from the list, leaving unique list of co-ordinates
2. For each co-ordinate it creates ONE pairing with every co-ordinate EXCEPT itself

Example: 4 co-ordinates
London
Manchester
Hull
Bristol

Created - pairings with distances calculated (6)
London \ Manchester
London \ Hull
London \ Bristol
Manchester \ Hull
Manchester \ Bristol
Hull \ Bristol

Not Created - Zero distances (4)

London \ London
Manchester \ Manchester
Hill \ Hull
Bristol \ Bristol

Not Created - same distance in opposite direction (6)

Manchester \ London
Hull \ London
Bristol \ London
Hull \ Manchester
Bristol \ Manchester
Bristol \ Hull


Q Are you saying that you want Zero distances included in results sheet?
 
Last edited:

strat919

Board Regular
Joined
May 15, 2019
Messages
54
Yes.... Zero distances included in results sheet.

Thanks for the info above:)
 
Last edited:

strat919

Board Regular
Joined
May 15, 2019
Messages
54
Also forgot to mention, the cpu usage reaches 28% in excel....way better.

I tried to edit the code to remove the duplicate deletion, but always got errors....lol.

So everything is PERFECT except the Zero distances need to be included in the results sheet. There would hardly ever be any.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,540
Office Version
365
Platform
Windows
I tried to edit the code to remove the duplicate deletion, but always got errors....lol.
Did you amend the size of array Pairs to match the increased number of items you were telling VBA to put inside it ? :confused:
- to save memory etc, the code limits the size of the array to only what is required

EXPLANATION
If every possible combination is allowed
- total number of pairings would be no of co-ordinates X no of co-ordinates
- with 4 co-ordinates (example in post#35) 4 X 4 = 16
- the calculation of PairCount is determined by what is being EXCLUDED from this loop
Code:
[COLOR=#000080]        
For a = 1 To UBound(List)
 For b = 1 To UBound(List)

 Next b
Next a
[/COLOR]
- unwanted "opposite" direction pairings are excluded (ie 6 pairings in our 4 X 4 example)
- the generic formula to exclude those particular unwanted duplications is ( n X (n + 1) ) / 2 [where n = no of co-ordinates]
- in our 4 X 4 example, that formula returns ( 4 X (4 + 1 ) ) / 2 = 10

CODE AMENDMENTS REQUIRED
- 2 lines to change in GeneratePairs

determine size of array Pairs by replacing
Code:
   PairCount = (UBound(List) ^ 2 - UBound(List)) / 2
with
Code:
   PairCount = (UBound(List) * (UBound(List) + 1)) / 2
amend what is placed in array Pairs by replacing
Code:
  If b < a Then
with
Code:
  If b <= a Then
 
Last edited:

strat919

Board Regular
Joined
May 15, 2019
Messages
54
Just returned from going out of town.

I replaced the above code and it returned a lot of zero distance values

I placed 500 initial entries, set it for 100 items to output, and it returned 100 zero distances. There are no duplicate pairs in the 500 entries.

I'm not sure what it is doing.

The version1 was perfect, except not returning zero distances if any

Maybe if you could post the entire code with your changes, I changed the code exactly as above, but who knows. I understand some of what's going on, but it still looks like Chinese to me......lol.

Thanks again and again another time:)
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,540
Office Version
365
Platform
Windows
Yes.... Zero distances included in results shee
The code is doing what I expected - it is now including all zero distances

4 co-ordinates (as in post#35)
Excel 2016 (Windows) 32 bit
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

Returns 4 zero distances and 6 unique non-zero distances
Excel 2016 (Windows) 32 bit
A
B
C
D
E
F
G
1
51.5074​
0.1278​
51.5074​
0.1278​
0.00​
LondonLondon
2
53.7676​
0.3274​
53.7676​
0.3274​
0.00​
HullHull
3
51.4545​
2.5879​
51.4545​
2.5879​
0.00​
BristolBristol
4
53.4808​
2.2426​
53.4808​
2.2426​
0.00​
ManchesterManchester
5
53.7676​
0.3274​
53.4808​
2.2426​
80.96​
HullManchester
6
51.4545​
2.5879​
51.5074​
0.1278​
105.94​
BristolLondon
7
51.4545​
2.5879​
53.4808​
2.2426​
140.79​
BristolManchester
8
53.7676​
0.3274​
51.5074​
0.1278​
156.42​
HullLondon
9
53.4808​
2.2426​
51.5074​
0.1278​
162.82​
ManchesterLondon
10
51.4545​
2.5879​
53.7676​
0.3274​
185.86​
BristolHull
Sheet: Results 190727 6.32 am


I think that you want some zero distances but not others but I am not sure which ones
- if that is the case, then we need put the ones that you want into an array and remove the others
- how do we identify the ones that you do want ?
- are they the newly added co-ordinates each time?
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,105,925
Messages
5,508,146
Members
408,667
Latest member
jh89

This Week's Hot Topics

Top