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

 

[vcoolio]

Hello Strat919,

Try it as follows:-

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.

 

[strat919]

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]

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

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

 

[Fazza]

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]

@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]

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]

Please post ...
- code for MergeColumnsAddComma
- typical data that above procedure is applied to (10 rows is enough)

thanks

 

[Fazza]

best wishes with the project

 

[Yongle]

1. Please confirm that this is what you are doing (and want speeded up)

Convert 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]Lat[/td][td]Long[/td][/tr]

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

2​

[/td][td]

17.695367​

[/td][td]

-64.882509​

[/td][/tr]

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

3​

[/td][td]

17.695367​

[/td][td]

-74.882509​

[/td][/tr]

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

4​

[/td][td]

17.695367​

[/td][td]

-84.882509​

[/td][/tr]

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

5​

[/td][td]

17.695367​

[/td][td]

-94.882509​

[/td][/tr]

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

6​

[/td][td][/td][td][/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Co-ordinates[/td][/tr][/table]

Converting to this

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][th]

F​

[/th][th]

G​

[/th][th]

H​

[/th][th]

I​

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

1​

[/td][td]Lat1[/td][td]Long1[/td][td][/td][td][/td][td]Lat2[/td][td]Long2[/td][td][/td][td]Distance[/td][td] formula[/td][/tr]

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

2​

[/td][td]

17.69537​

[/td][td]

-64.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-64.8825​

[/td][td][/td][td]

0​

[/td][td] =6371*ACOS(COS(RADIANS(90-A2))
*COS(RADIANS(90-E2))
+SIN(RADIANS(90-A2))
*SIN(RADIANS(90-E2))
*COS(RADIANS(B2-F2)))/1.609[/td][/tr]

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

3​

[/td][td]

17.69537​

[/td][td]

-64.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-74.8825​

[/td][td][/td][td]

658.3058​

[/td][td][/td][/tr]

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

4​

[/td][td]

17.69537​

[/td][td]

-64.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-84.8825​

[/td][td][/td][td]

1316.142​

[/td][td][/td][/tr]

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

5​

[/td][td]

17.69537​

[/td][td]

-64.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-94.8825​

[/td][td][/td][td]

1973.013​

[/td][td][/td][/tr]

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

6​

[/td][td]

17.69537​

[/td][td]

-74.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-64.8825​

[/td][td][/td][td]

658.3058​

[/td][td][/td][/tr]

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

7​

[/td][td]

17.69537​

[/td][td]

-74.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-74.8825​

[/td][td][/td][td]

0​

[/td][td][/td][/tr]

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

8​

[/td][td]

17.69537​

[/td][td]

-74.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-84.8825​

[/td][td][/td][td]

658.3058​

[/td][td][/td][/tr]

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

9​

[/td][td]

17.69537​

[/td][td]

-74.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-94.8825​

[/td][td][/td][td]

1316.142​

[/td][td][/td][/tr]

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

10​

[/td][td]

17.69537​

[/td][td]

-84.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-64.8825​

[/td][td][/td][td]

1316.142​

[/td][td][/td][/tr]

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

11​

[/td][td]

17.69537​

[/td][td]

-84.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-74.8825​

[/td][td][/td][td]

658.3058​

[/td][td][/td][/tr]

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

12​

[/td][td]

17.69537​

[/td][td]

-84.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-84.8825​

[/td][td][/td][td]

0​

[/td][td][/td][/tr]

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

13​

[/td][td]

17.69537​

[/td][td]

-84.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-94.8825​

[/td][td][/td][td]

658.3058​

[/td][td][/td][/tr]

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

14​

[/td][td]

17.69537​

[/td][td]

-94.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-64.8825​

[/td][td][/td][td]

1973.013​

[/td][td][/td][/tr]

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

15​

[/td][td]

17.69537​

[/td][td]

-94.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-74.8825​

[/td][td][/td][td]

1316.142​

[/td][td][/td][/tr]

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

16​

[/td][td]

17.69537​

[/td][td]

-94.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-84.8825​

[/td][td][/td][td]

658.3058​

[/td][td][/td][/tr]

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

17​

[/td][td]

17.69537​

[/td][td]

-94.8825​

[/td][td][/td][td][/td][td]

17.69537​

[/td][td]

-94.8825​

[/td][td][/td][td]

0​

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

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

 

[strat919]

Here is all the code in order for all the steps that I have been using:

Sub ExecuteAll()
Call MergeColumnsAddComma
Call GetUniquePairs
Call Text2Columns
Call deleteSheetByName
Call FindDistance
Call SortAllSheets
Call CopyXRows2Master
Call SortMasterSheetE
End Sub

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

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

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

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

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

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

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

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