Page 2 of 5 FirstFirst 1234 ... LastLast
Results 11 to 20 of 47

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

  1. #11
    Board Regular
    Join Date
    Jun 2014
    Posts
    835
    Post Thanks / Like
    Mentioned
    5 Post(s)
    Tagged
    0 Thread(s)

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

    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.

  2. #12
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.

  3. #13
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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
    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 by strat919; Jul 21st, 2019 at 05:19 PM.

  4. #14
    MrExcel MVP
    Join Date
    May 2006
    Location
    Excel 2003, Australia
    Posts
    9,152
    Post Thanks / Like
    Mentioned
    7 Post(s)
    Tagged
    3 Thread(s)

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

    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.
    To receive a better answer, put more work into asking the question.


  5. #15
    Board Regular Michael M's Avatar
    Join Date
    Oct 2005
    Location
    South Western NSW
    Posts
    17,804
    Post Thanks / Like
    Mentioned
    18 Post(s)
    Tagged
    2 Thread(s)

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

    @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 !
    Regards
    Michael M
    ---------------------------------------
    The more I learn, the less I seem to know.....A Please and Thank You cost nothing !
    It's easier to debug if we can see the whole macro !
    Home 2007 & 2013

    - Posting guidelines, forum rules and terms of use

    - To download Mr Excel HTML Maker

    - Try searching for your answer first, see how

    - Read the FAQs

    - List of BB codes


    [CODE]Place Your Code Here[/CODE]

  6. #16
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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

  7. #17
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,876
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

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

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

    thanks

  8. #18
    MrExcel MVP
    Join Date
    May 2006
    Location
    Excel 2003, Australia
    Posts
    9,152
    Post Thanks / Like
    Mentioned
    7 Post(s)
    Tagged
    3 Thread(s)

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

    best wishes with the project
    To receive a better answer, put more work into asking the question.


  9. #19
    Board Regular
    Join Date
    Mar 2015
    Posts
    3,876
    Post Thanks / Like
    Mentioned
    72 Post(s)
    Tagged
    7 Thread(s)

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

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

    Convert this:

    Excel 2016 (Windows) 32 bit
    A
    B
    1
    Lat Long
    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
    Lat1 Long1 Lat2 Long2 Distance 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 ?

  10. #20
    Board Regular
    Join Date
    May 2019
    Posts
    54
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •