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

[strat919]

I have some code to sort all sheets column E low to high. I have 18 sheets each with about a million rows. I can sort one sheet manually and it takes maybe 5 seconds. When I use this code, the 18 sheets take almost 10 min.

I will have any number sheets, depending on previous calculations. In this instance, it is 18.

Also, it takes way more memory than I would expect.

Thanks for any help

Sub SortAllSheets()
   'Descending sort on A:E using column E, all sheets in workbook
   Dim ws      As Worksheet
   For Each ws In Worksheets
      ws.Columns("A:E").Sort Key1:=ws.Columns("E"), Order1:=xlAscending
   Next ws
End Sub

 

[strat919]

I'm not sure how to post table in here, but here is the initial and desired results. I wasn't using any headers. Probably easier for me with no headers.



- initial latitude longitude would be in column A,B
- result of all combinations in column C,D (spread over many sheets because of row amount limitation in excel
- results of the distance in column E (over the many sheets)
- need all sheets sorted(I assume) so that only the first (x) rows could be copied to a master sheet
- sheet1 needs to be deleted at some point, probably after all combinations.... at least in the way I've been doing it, it does not contain the combinations..... only the initial data
* So basically I would
1- copy the latitude and longitude values into A,B
2- set the amount of rows (Change in code) that I want to be copied from all sheets to the master result sheet. The amount of rows from each sheet would be the same, so I would only set one value in the code.....will usually be 20 or 30.
3- Master list sorted low to high
4- End result!
You can probably tell by all the code above what is going on

I can't thank you enough for taking interest in this

I will be in and out due to death in family, but will check back as often as I can

David

 

[strat919]

I forgot to mention the the merge was only used because of the next macro. I assume the merge is not needed.

Also, I guess sorting would not be necessary after unique pairs if I could set the code to copy the lowest values over all sheets to be copied to master. I could set, say 500 results to master over all the sheets. That may make it a lot quicker not having to sort all sheets.

 

[strat919]

I guess you could say it picks x amount of lowest values out of all the sheets...not per sheet... and places them in master sheet. In the master result sheet it would have A,B,C,D,E like in all the other sheets. If you don't think this would save much time or memory, then the sorting all sheets method would be better for me.

 

[Michael M]

Your first code executes all macros.
If that is how the code is going to be run, why not combine the macros so that the "For each WS in Worksheets" isn't run multiple times.
Your various codes at the moment, loop through all the sheets, then the next code does the same sheet loop process, etc, etc.
It could nearly all be done in one series of loops ???

 

[strat919]

Hey Michael.......
I know very little about any of this, but when I look at it and I could be totally wrong here.

-
Sub Text2Columns() all sheets need to be delimited
-
Sub deleteSheetByName() Just one sheet is deleted
-
Sub FindDistance()
all sheets need distance
-
Sub SortAllSheets()
all sheets need to be sorted for next macro, unless I had code to pick (x) amount of the lowest long lat values from by distance values
-
Sub CopyXRows2Master()
top (x) amount of rows I set in the macro.... from all sheets . Results in the master, but not sorted in the master(next macro)
-
Sub SortMasterSheetE()
sort the master

Maybe I'm looking at it totally wrong, but doesn't all sheets have to be accessed in those macros?

Thanks

 

[Michael M]

Well, as an example, why can't "sortAll Sheets" and "CopytoMaster" be combined like this.
Note the sort is done before copy rows !
The text2columns probably could be thrown into this code as well...but what it means is the code is going through the sheets once only, not over and over again

Sub CopyXRows2Master()
Dim lr As Long, ws As Worksheet, ans As Long
Sheets.Add(after:=Worksheets(Sheets.Count)).Name = "Master"
lr = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
ans = 30
For Each ws In Worksheets
    If ws.Name <> "Master" Then
        With ws
        .Columns("A:E").Sort Key1:=ws.Range("E1"), Order1:=xlAscending
        .Rows("1:" & ans).Copy Sheets("Master").Range("A" & lr)
        lr = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row + 1
        End With
    End If
Next ws
End Sub

 

[Yongle]

Try this

To start with worksheet looks like this
Excel 2016 (Windows) 32 bit
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]

A​

[/th][th]

B​

[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

1​

[/td][td]

17.695367​

[/td][td]

-94.882509​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

2​

[/td][td]

22.604667​

[/td][td]

-89.515209​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

3​

[/td][td]

20.978867​

[/td][td]

-89.262209​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

4​

[/td][td]

19.682367​

[/td][td]

-87.809709​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

5​

[/td][td]

19.957467​

[/td][td]

-91.277409​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

6​

[/td][td]

20.025367​

[/td][td]

-86.121809​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

7​

[/td][td]

21.344367​

[/td][td]

-93.437609​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

8​

[/td][td]

26.171767​

[/td][td]

-90.014609​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

9​

[/td][td]

27.427167​

[/td][td]

-93.532009​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

10​

[/td][td]

20.042567​

[/td][td]

-87.880009​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

11​

[/td][td]

24.227967​

[/td][td]

-88.523609​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

12​

[/td][td]

24.139467​

[/td][td]

-93.652109​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

13​

[/td][td]

25.026667​

[/td][td]

-86.809209​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

14​

[/td][td]

19.714567​

[/td][td]

-91.068309​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

15​

[/td][td]

27.213467​

[/td][td]

-87.960409​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

16​

[/td][td]

24.800967​

[/td][td]

-92.572709​

[/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Sheet1[/td][/tr][/table]

I asked for 10 values to be returned :

Excel 2016 (Windows) 32 bit
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]

A​

[/th][th]

B​

[/th][th]

C​

[/th][th]

D​

[/th][th]

E​

[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

1​

[/td][td]

21.50117​

[/td][td]

-91.1147​

[/td][td]

21.49797​

[/td][td]

-91.12​

[/td][td]

0.406253​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

2​

[/td][td]

18.94137​

[/td][td]

-87.4702​

[/td][td]

18.94487​

[/td][td]

-87.4756​

[/td][td]

0.427896​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

3​

[/td][td]

19.01427​

[/td][td]

-90.0209​

[/td][td]

19.01157​

[/td][td]

-90.0282​

[/td][td]

0.512166​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

4​

[/td][td]

21.91217​

[/td][td]

-93.2721​

[/td][td]

21.92447​

[/td][td]

-93.2732​

[/td][td]

0.85295​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

5​

[/td][td]

20.12217​

[/td][td]

-89.9606​

[/td][td]

20.11197​

[/td][td]

-89.9746​

[/td][td]

1.149885​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

6​

[/td][td]

21.50377​

[/td][td]

-93.494​

[/td][td]

21.48577​

[/td][td]

-93.4935​

[/td][td]

1.244361​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

7​

[/td][td]

25.13587​

[/td][td]

-86.2795​

[/td][td]

25.13527​

[/td][td]

-86.2994​

[/td][td]

1.245712​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

8​

[/td][td]

20.11167​

[/td][td]

-87.9784​

[/td][td]

20.10727​

[/td][td]

-87.9595​

[/td][td]

1.263648​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

9​

[/td][td]

20.23217​

[/td][td]

-85.3814​

[/td][td]

20.22367​

[/td][td]

-85.3998​

[/td][td]

1.329925​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

10​

[/td][td]

27.59177​

[/td][td]

-87.1582​

[/td][td]

27.59537​

[/td][td]

-87.1796​

[/td][td]

1.334098​

[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

11​

[/td][td][/td][td][/td][td][/td][td][/td][td][/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Results 190724 10.18 pm[/td][/tr][/table]


Test on a COPY of your workbook!
Place the code in a NEW standard module

[B][COLOR=#006400]'this goes at TOP of module ABOVE all  procedures[/COLOR][/B]

    Option Explicit
    Private List() As Variant, Pairs() As Double
    Const Limit As Long = 500000
    Private PairCount As Long, ResultsCount As Long, Results As Worksheet, Data As Worksheet
 
[B][COLOR=#006400]'procedures [/COLOR][/B]

Sub Strat919()

    Dim t As Double:    t = Timer
    ResultsCount = InputBox("How many items to output ?", "User choice", 100)
    Call GeneratePairs
    Call GenerateResults
    MsgBox Round(Timer - t, 1) & " seconds"
End Sub

Private Sub GeneratePairs()
    Dim a As Long, b As Long, r As Long
    Set Data = [COLOR=#ff0000]ActiveSheet[/COLOR]
    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 5)
'place paired values in array and calculate distance
        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)
                    Pairs(r, 5) = GetDistance(Pairs(r, 1), Pairs(r, 2), Pairs(r, 3), Pairs(r, 4))
                End If
            Next b
        Next a
End Sub

Private Function GetDistance(ByVal Lat1, ByVal Long1, ByVal Lat2, ByVal Long2)
    With WorksheetFunction
        GetDistance = 6371 * .Acos(Cos(.Radians(90 - Lat1)) * Cos(.Radians(90 - Lat2)) + Sin(.Radians(90 - Lat1)) * Sin(.Radians(90 - Lat2)) * Cos(.Radians(Long1 - Long2))) / 1.609
    End With
End Function

Private Sub GenerateResults()
    Dim r2  As Long, r1 As Long, c As Long, LimitCount 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")
[COLOR=#006400][I]'how many times to move subsets of values?, how many items in last subset?[/I][/COLOR]
    LimitCount = WorksheetFunction.RoundDown(PairCount / Limit, 0)
    Remainder = PairCount Mod Limit
[I][COLOR=#006400]'move each subset in sequence[/COLOR][/I]
    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)
    Application.ScreenUpdating = False
    Dim rTemp As Long, r As Long, c As Long, tempArr()
    ReDim tempArr(1 To lastItem - firstItem + 1, 1 To 5)
[I][COLOR=#006400]'move to temp array[/COLOR][/I]
    For r = firstItem To lastItem
        rTemp = rTemp + 1
        For c = 1 To 5
            tempArr(rTemp, c) = Pairs(r, c)
        Next c
    Next r
[I][COLOR=#006400]'write to worksheet, sort and clear rows not required[/COLOR][/I]
    Results.Cells(Results.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(tempArr), 5) = tempArr
    Results.Range("A:E").Sort Key1:=Results.Range("E1"), Order1:=xlAscending, Header:=xlNo
    Results.Range("A1").Offset(ResultsCount).Resize(Limit, 5).ClearContents
End Sub

VBA actions
- the user is asked how many items to return (let's assume user wants 200 )
- co-ordinates in columns A and B of active sheet are written to a 2 column array
- possible pairings are determined, distances calculated and values written to a 5 column array
- results are written to a new worksheet
- a restricted no of items are written to the worksheet, sorted (ascending), and the first 200 rows retained
- the restriction is the value of constant Limit
- then next batch of items are witten to the sheet (now contains Limit + 200), sorted and the first 200 rows retained
etc until all values dealt with

Trapping errors etc
- have not had time to be sophisticated
- what could cause VBA problems with your data ( text instead of values, no values , values that break the formula etc)
- can incorporate error checking later

User Options
- do you always want the shortest distances ?
- what else is required ?

Let me know how you get on

 

[Yongle]

I forgot to say that I added a timer so that different values for Limit can be tested to measure impact on performance

 

[strat919]

I'm going to have to address you as Mr. Yongle from now on It works perfectly.

I entered 4500 lat long entries and the time for entire process was 3.5 min. It was taking little over 5 min before with same data.

I entered 12,500 entries and it took 24 minutes for results. Before, for some reason, it would crash when the number of entries were over about 8000.

The most incredible thing is the memory usage. Even with 12,500 entries, it only used between 4 and 5 gigs of memory. Before with the 12,500 entries it was approaching 80 to 95% of my 32 gigs. Maybe that was the problem causing the crashes.

One thing I don't understand... excel only uses 18% or less of my processor speed during calculations. I'm assume that is an excel problem. It never seems to to go over 18 to 20% for anything.

I can't thank you enough for this Mr. Yongle! I hope it didn't take you too long for this. I owe ya buddy.

Thank you SO MUCH!

Thank you too Michael M and everybody else

David

 

[strat919]

Sorry..... I didn't answer your questions.

- I will always need the shortest distance
- Nothing else is required

As far as the limit, here is how I plan to work. Just for your information.
I will have a master list of lat long coordinates. During the week, users will input new lat long coordinates to my website. Each week I will add their coordinates to the master list and check with your code to make sure there are not any duplicates. So at that point, I have no duplicates on master list. Then the next week I do the same. So I will use a limit of maybe 20 because most of the time I probably will have no duplicates. This is experimental and is probably the first attempt at this, so I will just have to see how it goes. The coordinates will be world wide. I just have to be assured I do not have any 3D objects on top of each other. I want to be correct as possible even though it will require more work. I will let you know when I have it up and running if interested. I'm hoping in about a month and a half.