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

vcoolio

Well-known Member
Joined
Jun 29, 2014
Messages
975
Hello Strat919,

Try it as follows:-

Code:
Sub SortAllSheets()
 
   Dim ws As Worksheet
   
   For Each ws In Worksheets
       ws.Range("A2", ws.Range("E" & ws.Rows.Count).End(xlUp)).Sort  ws.["E2"], 1  '---->Assuming there are headings in Row1.
   Next ws
   
End Sub
Add the 'Application' lines as suggested by Michael.

In your opening post, you're sorting entire columns (i.e. all one million plus rows). In the code above, only the actual data rows will be sorted in Columns A:E.

However, based on your post #10 , the number of procedures that are being called will certainly slow down the whole process. The merge columns code I personally would do away with as merged cells create havoc with codes. If you must keep it then move it down as the last call.

Test the above code on its own in a copy of your workbook and then with the other codes.

I hope that this helps.

Cheerio,
vcoolio.
 

Some videos you may like

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

strat919

Board Regular
Joined
May 15, 2019
Messages
54
Thanks Vccolio:) I will try that. I'm nor sure if I can do away with the merge columns or move it in the sequence. The next macro depends on that. I will look into seeing if I could work around this.

It has taken me almost 2 weeks with everyone's help to get this so far. There is no way I could code all this myself.

Is the havoc created with the merge because it is running with other macros, or in general? Maybe I could merge manually and then automate the rest?

What I notice is that the merge happens almost instantly if I do it manually and by itself, whereas if I run it automated with the rest.....I see the merge later in the sequence....like the computer is calculating the merge and the next macro at the same time. I don't know... maybe. It does present the correct values at the end though.

But...it does crash with start rows of around 10,000 rows...resulting in around 30 sheets at a million per sheet. It doesn't crash if I run the sequence of macros, manually one at a time. So something is different. I have 32 gigs of ram and it gets to around 80% so I should be fine there.

I'm still wondering if there is a way to make sure one macro is totally complete before moving to the next while automating.
 

strat919

Board Regular
Joined
May 15, 2019
Messages
54
Ok..... I will able to run the macros without a merge. Yongle wrote me the code to get unique pairs from row A and can be spread over many sheets to alleviate the million row limit. It works perfectly:)

I can remove the merge macro if the same code could take say A1 and B1 as a single entity instead of just A1..... and find all unique combinations and spread them over as many sheets as it takes. Hopefully that would work better than have the merge step.

Here is the code that Yongle so kindly wrote for me:)
Rich (BB code):
Public Sub GetUniquePairs()
    Application.ScreenUpdating = False
    Const maximum = 500000
    Dim lastRow As Long, thisRow As Long
    Dim i As Long, j As Long
    Dim ws As Worksheet, Results As Worksheet
    Dim Res(1 To maximum, 1 To 1) As Variant
    
    Set ws = ActiveSheet
    Set Results = Sheets.Add
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    thisRow = 1
    
    For i = 1 To lastRow - 1
        For j = i + 1 To lastRow
            c = c + 1
            Res(thisRow, 1) = ws.Cells(i, 1).Value & "," & ws.Cells(j, 1).Value
            thisRow = thisRow + 1
                If thisRow = maximum Then
                    thisRow = 1
                    Results.Cells(1, 1).Resize(maximum).Value = Res
                    Erase Res
                    Set Results = Sheets.Add
                End If
                If i = lastRow - 1 Then
                    Results.Cells(1, 1).Resize(maximum).Value = Res
                    Erase Res
                End If
        Next j
    Next i
End Sub
 
Last edited:

Fazza

MrExcel MVP
Joined
May 17, 2006
Messages
9,358
The thread began asking of the code should be written differently. There are large data volumes so a database type approach is obvious. Maybe the data should be in a proper database. Staying within Excel is perhaps sub-optimal.

There can be good reasons for sorting data; though maybe even that can be changed - just don't sort at all. Or instead of sorting all the sheets at once, just sort one worksheet when it is activated.
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
18,889
Office Version
2013
Platform
Windows
@Fazza
Agreed !!
However, I usually use a "sandpit" worksheet to carry out sorting / filtering / extracting
and then clear that sheet when finished.
Sorting every sheet, every time, does seem a bit of a waste of resources to me !
 

strat919

Board Regular
Joined
May 15, 2019
Messages
54
To be honest, I'm not sure how much data I will be sorting. I'm developing a addon for a flight simulator where the user will be able to add their own coordinates for 3d objects. I have no idea how this will takeoff or if it does well at all. I've been working on this for 7 months. I'm retired UPS, so I have some free time to develop this.

The reason for all this is that.... say 2 people in a city enter the coordinates for the same location. They will not have the same exact coordinates but close. I need to delete one of their entries so there will not be a duplicate object at that location.

I understand that if the volume of data becomes huge, I will have to utilize a database program. But for now, 5000 entries only takes about 6 min to get the desired result and 10,000 is doable. If I get 50,000 entries, I will hire all of you and relocate you here.....lol.

I still would like to have the code above changed to see if merging is causing the excel crashing..... if possible:)
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,084
Office Version
365
Platform
Windows
Please post ...
- code for MergeColumnsAddComma
- typical data that above procedure is applied to (10 rows is enough)

thanks
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,084
Office Version
365
Platform
Windows
1. Please confirm that this is what you are doing (and want speeded up)

Convert this:

Excel 2016 (Windows) 32 bit
A
B
1
LatLong
2
17.695367​
-64.882509​
3
17.695367​
-74.882509​
4
17.695367​
-84.882509​
5
17.695367​
-94.882509​
6
Sheet: Co-ordinates

Converting to this

Excel 2016 (Windows) 32 bit
A
B
C
D
E
F
G
H
I
1
Lat1Long1Lat2Long2Distance formula
2
17.69537​
-64.8825​
17.69537​
-64.8825​
0​
=6371*ACOS(COS(RADIANS(90-A2))
*COS(RADIANS(90-E2))
+SIN(RADIANS(90-A2))
*SIN(RADIANS(90-E2))
*COS(RADIANS(B2-F2)))/1.609
3
17.69537​
-64.8825​
17.69537​
-74.8825​
658.3058​
4
17.69537​
-64.8825​
17.69537​
-84.8825​
1316.142​
5
17.69537​
-64.8825​
17.69537​
-94.8825​
1973.013​
6
17.69537​
-74.8825​
17.69537​
-64.8825​
658.3058​
7
17.69537​
-74.8825​
17.69537​
-74.8825​
0​
8
17.69537​
-74.8825​
17.69537​
-84.8825​
658.3058​
9
17.69537​
-74.8825​
17.69537​
-94.8825​
1316.142​
10
17.69537​
-84.8825​
17.69537​
-64.8825​
1316.142​
11
17.69537​
-84.8825​
17.69537​
-74.8825​
658.3058​
12
17.69537​
-84.8825​
17.69537​
-84.8825​
0​
13
17.69537​
-84.8825​
17.69537​
-94.8825​
658.3058​
14
17.69537​
-94.8825​
17.69537​
-64.8825​
1973.013​
15
17.69537​
-94.8825​
17.69537​
-74.8825​
1316.142​
16
17.69537​
-94.8825​
17.69537​
-84.8825​
658.3058​
17
17.69537​
-94.8825​
17.69537​
-94.8825​
0​
Sheet: Distances

2. Should column H contain the formula OR calculated value ?
 

strat919

Board Regular
Joined
May 15, 2019
Messages
54
Here is all the code in order for all the steps that I have been using:
Code:
Sub ExecuteAll()
Call MergeColumnsAddComma
Call GetUniquePairs
Call Text2Columns
Call deleteSheetByName
Call FindDistance
Call SortAllSheets
Call CopyXRows2Master
Call SortMasterSheetE
End Sub
Code:
Sub MergeColumnsAddComma()
   With Range("C1:C" & Range("A" & Rows.Count).End(xlUp).Row)
      .Formula = "=TEXTJOIN("","",TRUE,A1:B1)"
      .Value = .Value
   End With
   Columns("A:B").Delete
End Sub
Code:
Public Sub GetUniquePairs()
    Application.ScreenUpdating = False
    Const maximum = 1048576
    Dim lastRow As Long, thisRow As Long
    Dim i As Long, j As Long
    Dim ws As Worksheet, Results As Worksheet
    Dim Res(1 To maximum, 1 To 1) As Variant
    
    Set ws = ActiveSheet
    Set Results = Sheets.Add
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    thisRow = 1
    
    For i = 1 To lastRow - 1
        For j = i + 1 To lastRow
            c = c + 1
            Res(thisRow, 1) = ws.Cells(i, 1).Value & "," & ws.Cells(j, 1).Value
            thisRow = thisRow + 1
                If thisRow = maximum Then
                    thisRow = 1
                    Results.Cells(1, 1).Resize(maximum).Value = Res
                    Erase Res
                    Set Results = Sheets.Add
                End If
                If i = lastRow - 1 Then
                    Results.Cells(1, 1).Resize(maximum).Value = Res
                    Erase Res
                End If
        Next j
    Next i
End Sub
Code:
Sub Text2Columns()
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
    Select Case UCase(ws.Name)
        Case "MASTER", "DATA"
            'do nothing
        Case Else
            ws.Columns(1).TextToColumns Destination:=ws.Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
                Tab:=False, _
                Semicolon:=False, _
                Comma:=True, _
                Space:=False, _
                Other:=False, OtherChar:="|", _
                FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
                TrailingMinusNumbers:=True
    End Select
Next ws
Application.ScreenUpdating = True
End Sub
Code:
Sub deleteSheetByName()

     

        'Source: https://powerspreadsheets.com/

        'For further information: https://powerspreadsheets.com/excel-vba-delete-sheet/

     

        'declare variable to hold name of sheet you want to delete

        Dim mySheetName As String

    

        'specify name of sheet you want to delete

        mySheetName = "Sheet1"

     

        'suppress the dialog box that asks the user to confirm the sheet deletion

        Application.DisplayAlerts = False

     

        'identify sheet you want to delete, and delete it

        ThisWorkbook.Sheets(mySheetName).Delete

     

        're-enable the display of alerts and messages

        Application.DisplayAlerts = True

     

    End Sub
Code:
Sub FindDistance()
Dim ws As Worksheet, lr As Long
For Each ws In Worksheets
lr = ws.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
    ws.Range("E1:E" & lr).Formula = "=6371*ACOS(COS(RADIANS(90-A1))*COS(RADIANS(90-C1))+SIN(RADIANS(90-A1))*SIN(RADIANS(90-C1))*COS(RADIANS(B1-D1)))/1.609"
Next ws
End Sub
Code:
Sub SortAllSheets()
   Application.ScreenUpdating = False
   '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.Range("E1"), Order1:=xlAscending
      Application.ScreenUpdating = True
   Next ws
End Sub
Code:
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
        .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
Code:
Sub SortMasterSheetE()
'
' SortMasterSheetE Macro
'

'
    Cells.Select
    ActiveWorkbook.Worksheets("Master").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Master").Sort.SortFields.Add2 Key:=Range("E1:E1000") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Master").Sort
        .SetRange Range("A1:E1000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
End Sub
I will show initial and desired result in next post
 

Watch MrExcel Video

Forum statistics

Threads
1,100,023
Messages
5,472,060
Members
406,797
Latest member
kh999

This Week's Hot Topics

Top