Page 1 of 2 12 LastLast
Results 1 to 10 of 19

Thread: Just testing. Testing some sort routines. No reply needed

  1. #1
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    Just testing. Testing some sort routines. No reply needed

    Just testing


    test HHKJHDHJHDJAHDKJHD

    TEST BLAH



    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg.9iEktVkTAHk9iF9_pdsh r6
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ-
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg.9iDVgy6wzct9iFBxma9z XI
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg.9iDQN7TORHv9iFGQQ5z_ 3f
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg.9iDLC2uEPRW9iFGvgk11 nH
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg.9iH3wvUZj3n9iHnpOxOe Xa
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg.9iGReNGzP4v9iHoeaCpT G8
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I




    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0
    https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA
    Last edited by DocAElstein; 07-09-2023 at 07:45 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  2. #2
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Code:
    Option Explicit
    
    '
    ' Simplist Sort
    Sub SimpleSort()
    Rem 0 test data, worksheets info
    Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
    Dim RngToSort As range: Set RngToSort = WsS.range("A2:B6")
    ' alternative:
     Set RngToSort = Selection '                          ' Selection.JPG : https://imgur.com/HnCdBt8
    Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use  .Value  for a range capture of this sort because  .Value  returns a field of Variant types.  But also at this stage we want to preserve string and number types
    Dim arrOut() As Variant: Let arrOut() = arrTS() ' could simply use the original array and sort that
    ' column to be used for determining order of rows sorted array: the values in this column will be looked at
    Dim Clm As Long: Let Clm = 1
    Rem 1 Simple Bubble Sort
    Dim rOuter As Long ' ========================================Outer Loop=====================================
        For rOuter = 1 To UBound(arrTS(), 1) - 1 ' For row 1 to the (last row -1)  last row, given by the first dimension upper limit of the array
        Dim rInner As Long ' -------Inner Loop-------------------------------------------------
            For rInner = rOuter + 1 To UBound(arrOut(), 1)
                'If arrOut(rOuter, Clm) > arrOut(rInner, Clm) Then           ' This means that I am bigger than the next. So I will swap . I keep doing this which will have the effect of putting the smallest in the current rOuter. By the this and all next rOuter, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next rOuter.
                If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
                Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
                Dim Clms As Long '-------| with the condition met  a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
                    For Clms = 1 To UBound(arrOut(), 2)
                     Let Temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = Temp
                    Next Clms '----------| for each column in the array at the two rows rOuter and rInner
                Else
                End If
            Next rInner ' ---------------------------------------------------------------------
        Next rOuter ' ===========================================================================================
    Rem 2 Output for easy of demo
     Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut
     Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
    End Sub
    ' Approximate equivalent to the above routune, using VBA Range.Sort Method '  https://docs.microsoft.com/de-de/off...cel.range.sort
    Sub Range_Sort()
    Rem 0 test data, worksheets info
    Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
    Dim RngToSort As range: Set RngToSort = WsS.range("A2:B6")
    ' alternative:
     Set RngToSort = Selection '                          ' Selection.JPG : https://imgur.com/HnCdBt8
    Rem 1 For demo purposes we will sort a copy of the range
     RngToSort.Copy Destination:=RngToSort.Offset(0, RngToSort.Columns.Count)
     Dim RngCopy As range: Set RngCopy = RngToSort.Offset(0, RngToSort.Columns.Count)
     RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlAscending, MatchCase:=False
    Rem 2 Output for easy of demo
     Let RngCopy.Interior.Color = vbYellow
    End Sub


    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg.9h5lFRmix1R9h78GftO_ iE
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h77HSGDH 4A
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h76fafzc EJ
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h759YIjl aG
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg.9h740K6COOA9h74pjGcb Eq
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg
    https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgzJJUDVv2Mb6YGkPYh4AaABAg.9h5uPRbWIZl9h7165DZd jg
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 07-10-2023 at 07:22 PM.

  3. #3
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    March 2019 protokol Range.Sort method

    Code:
    Sub ReorgBy3Criteria()
    Rem 0 error handling
    On Error GoTo TheEnd:
    Rem 1 worksheet info
     Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
    Dim objwinToSort As Object: Set objwinToSort = Windows("" & DieseArbeitsmappe1.ProWb.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
    Dim wksToSort As Worksheet: Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
    Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
    Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
    Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
    Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3482 '454 '99
    Dim rngToSort As Range: Set rngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
    Dim ArrrngOrig() As Variant: Let ArrrngOrig() = rngToSort.Value ' This is used as a back up to restore the original range
                          Let Application.EnableEvents = False                                         ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
    Rem 3 VBA Range.Sort Method
    '       xlDescending Biggest at Top   H Kcal                         J Fett                                                   L eiweiss
    'rngToSort.Sort Key1:=wksToSort.Columns("h"), order1:=xlDescending, Key2:=wksToSort.Columns("j"), order2:=xlDescending, Key3:=wksToSort.Columns("l"), order3:=xlDescending 'X Nat
    'Standard unter    ----    Kcal Highest H  ,at Top               , second most J Fett          , highest at Top      , third Natrium X             ,    most at top
    rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
                          Let Application.EnableEvents = True
    Rem 4 Msg Box check if all is well, if not put original enties back in.                                                                                 COMMENTED OUT FOR SPEED TESTS
    Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
     Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
        If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
         ' all is well - carry on after  End If
        Else
         Let Application.EnableEvents = False
         Let rngToSort.Value2 = ArrrngOrig() 'Full repair!!Put back as it was
         Let Application.EnableEvents = True
        End If
    Exit Sub ' Routine end if no errors____________________________________________________________________
    TheEnd: ' Error handling code section
     Let Application.EnableEvents = True                                                                      ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a  .EnableEvents = False   and before a  .EnableEvents = True
     MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
    End Sub 'ReorgBy3Criteria
    '
    Last edited by DocAElstein; 03-11-2019 at 02:26 AM.

  4. #4
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    Range.Sort Pro routine and Calling code Sub CallArraySort()

    Routines used to get results of next few post.

    Code:
    Option Explicit
    Sub ReorgBy3Criteria()
    Rem 0 error handling
    On Error GoTo TheEnd:
    Rem 1 worksheet info
    ' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
    Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
    Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
     Set wksToSort = ThisWorkbook.Worksheets("Sheet1")
    Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
    Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
    Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
    Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3482 '454 '99
    Dim rngToSort As Range: Set rngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
    Dim ArrrngOrig() As Variant: Let ArrrngOrig() = rngToSort.Value ' This is used as a back up to restore the original range
                          Let Application.EnableEvents = False                                         ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
    Rem 3 VBA Range.Sort Method
    '       xlDescending Biggest at Top   H Kcal                         J Fett                                                   L eiweiss
    'rngToSort.Sort Key1:=wksToSort.Columns("h"), order1:=xlDescending, Key2:=wksToSort.Columns("j"), order2:=xlDescending, Key3:=wksToSort.Columns("l"), order3:=xlDescending 'X Nat
    'Standard unter    ----    Kcal Highest H  ,at Top               , second most J Fett          , highest at Top      , third Natrium X             ,    most at top
    rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
                          Let Application.EnableEvents = True
    Rem 4 Msg Box check if all is well, if not put original enties back in.                                                                                 COMMENTED OUT FOR SPEED TESTS
    Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
     Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
        If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
         ' all is well - carry on after  End If
        Else
         Let Application.EnableEvents = False
         Let rngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was
         Let Application.EnableEvents = True
        End If
    Exit Sub ' Routine end if no errors____________________________________________________________________
    TheEnd: ' Error handling code section
     Let Application.EnableEvents = True                                                                      ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a  .EnableEvents = False   and before a  .EnableEvents = True
     MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
    End Sub 'ReorgBy3Criteria
    '
    Function CL(ByVal lclm As Long) As String 'Using chr function and Do while loop      For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html
    'Dim rest As Long 'Variable for what is "left over" after subtracting as many full 26's as possible
        Do
        '    Let rest = ((lclm - 1) Mod 26) 'Gives 0 to 25 for Column Number "Left over" 1 to 26. Better than ( lclm Mod 26 ) which gives 1 to 25 for clm 1 to 25 then 0 for 26
        '    Let FukOutChrWithDoWhile = Chr(65 + rest) & FukOutChrWithDoWhile 'Convert rest to Chr Number, initially with full number so the "units" (0-25), then number of 26's left over (if the number was so big to give any amount of 26's in it, then number of 26's in the 26's left over (if the number was so big to give any amount of 26 x 26's in it, Enit ?
        '    'OR
        Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL
        Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest.
        'lclm = (lclm - (rest + 1)) \ 26 ' As the number is effectively truncated here, any number from 1 to (rest +1)  will do in the formula
        Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it
    End Function
    '   https://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213887
    '
    ' Calling code for the main Array sort routine
    Sub CallArraySort()
    Rem 0 error handling
    On Error GoTo TheEnd:
    Rem 1 worksheet info
    ' Call DieseArbeitsmappe1.FillMeGlobsUpMate ' Global variables filled for example that for open daily Diet Protokol
    Dim objwinToSort As Object: Set objwinToSort = Windows("" & ThisWorkbook.Name & "") 'Mainly for convenience, but would give possibility of referring to a sheet "quasi" as the active even if you do not have got it "active" in front of you
    Dim wksToSort As Worksheet ': Set wksToSort = DieseArbeitsmappe1.ProWb.Worksheets("" & "Sheet1" & "")
     Set wksToSort = ThisWorkbook.Worksheets("Sheet1")
    Rem 2 Range for sort is based on Window selection. For convenience only rows selection is necerssary
    Dim StRow As Long, stClm As Long, StpRow As Long, StpClm As Long
    Let StRow = objwinToSort.Selection.Row: Let stClm = 1 'objwinToSort.Selection.Column ' Select any column or columns of rows to sort
    Let StpRow = StRow + objwinToSort.Selection.Rows.Count - 1: Let StpClm = 3488 ' 3488 ' 3482 '454 '99
    Dim rngToSort As Range: Set rngToSort = wksToSort.Range(CL(stClm) & StRow & ":" & CL(StpClm) & StpRow) ' Use column letter function for column letters
    Dim ArrrngOrig() As Variant: Let ArrrngOrig() = rngToSort.Value ' This is used as a back up to restore the original range
                          Let Application.EnableEvents = False                                         ' This is necerssary to turn off some event coding which I have which springs into action when anything is done in the worksheet
    Rem 3 Array sort routine alternative coding
    '3a) arguments for Called routine
    Dim cnt As Long, strIndcs As String: Let strIndcs = " "
        For cnt = 1 To rngToSort.Rows.Count
         Let strIndcs = strIndcs & cnt & " "
        Next cnt
    Debug.Print strIndcs
    Dim arrTS() As Variant '  : Let arrTS() = ArrrngOrig()                      '  '3c) alternative
    '3b) Do sort
    '  Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc ")  '  '3c) alternative
    '  Let rngToSort.Value = arrTS()                                            '  '3c) alternative
    '3c)
    arrTS() = rngToSort.Value: Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc "): rngToSort.Value = arrTS()
                          Let Application.EnableEvents = True
    Rem 4 Msg Box check if all is well, if not put original enties back in.                                                                                 COMMENTED OUT FOR SPEED TESTS
    Dim Response As Integer 'In VBA Butons "yes is 6, 7 is "no"
     Let Response = MsgBox(Prompt:="Is all OK?", Buttons:=vbYesNo, Title:="File Check") ' Displays a message box with the yes and no options.
        If Response = vbYes Then 'Do nothing, that is to say just carry on after End of If
         ' all is well - carry on after  End If
        Else
         Let Application.EnableEvents = False
         Let rngToSort.Value = ArrrngOrig() 'Full repair!!Put back as it was
         Let Application.EnableEvents = True
        End If
    Exit Sub ' Routine end if no errors____________________________________________________________________
    TheEnd: ' Error handling code section
     Let Application.EnableEvents = True                                                                      ' In the Case of an error I want to ensure that I turn back on my normal events. This is necerssary incase the error occured between after a  .EnableEvents = False   and before a  .EnableEvents = True
     MsgBox Prompt:=Err.Number & vbCr & vbLf & Err.Description
    End Sub
    Last edited by DocAElstein; 03-11-2019 at 11:51 AM.

  5. #5
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    Part of original range

    _____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    H
    I
    J
    K
    L
    M
    N
    O
    P
    Q
    R
    S
    T
    U
    V
    W
    X
    16691
    118
    0.2
    7.8
    3.1
    3.1
    34
    0.1
    16692
    123
    0.2
    7
    8.7
    8.5
    30
    0.1
    0
    16693
    120
    0.2
    7.4
    5.7
    5.7
    32
    0
    0.1
    16694
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16695
    118
    0.2
    7.8
    3.1
    3.1
    34
    0
    0
    0.1
    16696
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16697
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16698
    119
    0.2
    7.5
    5.1
    5.1
    33
    0
    0.1
    16699
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16700
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    0
    0
    16701
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16702
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16703
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16704
    117
    0.2
    7.7
    3.1
    3.1
    34
    0.1
    16705
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16706
    117
    0.2
    7.8
    3.1
    3.1
    34
    0.1
    16707
    117
    0.2
    7.7
    3.1
    3.1
    34
    0.1
    16708
    120
    0.2
    6.9
    8.4
    8.4
    30
    0.1
    0
    0
    16709
    321
    17
    19
    10
    1.8
    24
    0
    0.3
    16710
    121
    0.2
    6.9
    8.8
    8.8
    30
    0.1
    16711
    300
    6.8
    29
    16
    8.7
    17
    0
    0.3
    0.1
    16712
    233
    7.3
    15
    13
    5.2
    16
    0.1
    0
    16713
    186
    0.8
    19
    12
    11
    28
    0.1
    0.2
    0.1
    Worksheet: Sheet1

  6. #6
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Results from Sub ReorgBy3Criteria()

    _____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    H
    I
    J
    K
    L
    M
    N
    O
    P
    Q
    R
    S
    T
    U
    V
    W
    X
    16691
    321
    17
    19
    10
    1.8
    24
    0
    0.3
    16692
    300
    6.8
    29
    16
    8.7
    17
    0
    0.3
    0.1
    16693
    233
    7.3
    15
    13
    5.2
    16
    0.1
    0
    16694
    186
    0.8
    19
    12
    11
    28
    0.1
    0.2
    0.1
    16695
    123
    0.2
    7
    8.7
    8.5
    30
    0.1
    0
    16696
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16697
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16698
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16699
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16700
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16701
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16702
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    0
    0
    16703
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16704
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16705
    121
    0.2
    6.9
    8.8
    8.8
    30
    0.1
    16706
    120
    0.2
    6.9
    8.4
    8.4
    30
    0.1
    0
    0
    16707
    120
    0.2
    7.4
    5.7
    5.7
    32
    0
    0.1
    16708
    119
    0.2
    7.5
    5.1
    5.1
    33
    0
    0.1
    16709
    118
    0.2
    7.8
    3.1
    3.1
    34
    0
    0
    0.1
    16710
    118
    0.2
    7.8
    3.1
    3.1
    34
    0.1
    16711
    117
    0.2
    7.8
    3.1
    3.1
    34
    0.1
    16712
    117
    0.2
    7.7
    3.1
    3.1
    34
    0.1
    16713
    117
    0.2
    7.7
    3.1
    3.1
    34
    0.1
    Worksheet: Sheet1

    Time .11secs
    Last edited by DocAElstein; 03-11-2019 at 02:52 AM.

  7. #7
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Results from Sub CallArraySort()

    _____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    H
    I
    J
    K
    L
    M
    N
    O
    P
    Q
    R
    S
    T
    U
    V
    W
    X
    16691
    321
    17
    19
    10
    1.8
    24
    0
    0.3
    16692
    300
    6.8
    29
    16
    8.7
    17
    0
    0.3
    0.1
    16693
    233
    7.3
    15
    13
    5.2
    16
    0.1
    0
    16694
    186
    0.8
    19
    12
    11
    28
    0.1
    0.2
    0.1
    16695
    123
    0.2
    7
    8.7
    8.5
    30
    0.1
    0
    16696
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16697
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16698
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16699
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16700
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16701
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16702
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    0
    0
    16703
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16704
    123
    0.2
    7
    8.9
    8.9
    30
    0.1
    16705
    121
    0.2
    6.9
    8.8
    8.8
    30
    0.1
    16706
    120
    0.2
    6.9
    8.4
    8.4
    30
    0.1
    0
    0
    16707
    120
    0.2
    7.4
    5.7
    5.7
    32
    0
    0.1
    16708
    119
    0.2
    7.5
    5.1
    5.1
    33
    0
    0.1
    16709
    118
    0.2
    7.8
    3.1
    3.1
    34
    0
    0
    0.1
    16710
    118
    0.2
    7.8
    3.1
    3.1
    34
    0.1
    16711
    117
    0.2
    7.8
    3.1
    3.1
    34
    0.1
    16712
    117
    0.2
    7.7
    3.1
    3.1
    34
    0.1
    16713
    117
    0.2
    7.7
    3.1
    3.1
    34
    0.1
    Worksheet: Sheet1

    Time .7 secs
    Last edited by DocAElstein; 03-11-2019 at 02:55 AM.

  8. #8
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    Some timimg results. Range.Sort v Sub SimpleArraySort6(

    The two codes are simply modified to give a time measurement thus:
    Range.Sort Method:
    Code:
    Dim StartTime As Double: Let StartTime = Timer
    rngToSort.Sort Key1:=wksToSort.Columns("H"), order1:=xlDescending, Key2:=wksToSort.Columns("J"), order2:=xlDescending, Key3:=wksToSort.Columns("X"), order3:=xlDescending 'X Nat
     MsgBox prompt:=Round(Timer - StartTime, 2)
    Array Sort coding ( In recursion code): ( Sub SimpleArraySort6( )
    Code:
    '3c)
    Dim StartTime As Double: Let StartTime = Timer
    arrTS() = rngToSort.Value: Call SimpleArraySort6(1, arrTS(), strIndcs, " 8 Desc 10 Desc 24 Desc "): rngToSort.Value = arrTS()
     MsgBox prompt:=Round(Timer - StartTime, 2)
    Part of original data test range
    _____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    H
    I
    J
    K
    W
    X
    Y
    824
    338
    0.1
    0
    825
    826
    351
    0.1
    827
    342
    0.1
    0
    828
    342
    0
    829
    341
    0.1
    0
    830
    338
    1
    0
    831
    338
    0.1
    0
    832
    338
    0.1
    0.1
    833
    337
    0.5
    0.1
    834
    337
    0.1
    0
    835
    337
    0
    0.1
    836
    336
    0.2
    0
    837
    335
    0.1
    0
    838
    334
    0
    0.1
    839
    333
    0.2
    0
    840
    332
    0.2
    0
    841
    332
    0.1
    0.1
    842
    332
    0.1
    0
    843
    331
    0.1
    0.1
    844
    331
    0.1
    0.1
    845
    329
    0.2
    0
    846
    329
    0.1
    0
    847
    326
    0.3
    0
    848
    326
    0.3
    0
    849
    326
    0.2
    0
    850
    326
    0.1
    0
    851
    324
    0.1
    0.1
    852
    324
    0.1
    0
    853
    319
    0.2
    0.1
    854
    318
    0.5
    0.1
    855
    316
    0.2
    0.1
    856
    279
    0.5
    0.1
    857
    232
    0.1
    0
    858
    230
    0.2
    0
    859
    215
    0
    0
    860
    861
    338
    0.1
    0.1
    862
    339
    0.1
    0
    863
    337
    0.1
    0.1
    864
    865
    338
    1
    0
    Worksheet: Sheet1


    "ProAktuellex8600x2SortTime.xlsm" https://app.box.com/s/af7891hzmd3sbfnnsmx5b28ktec6wwjo
    Last edited by DocAElstein; 03-14-2019 at 03:38 PM.

  9. #9
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Range.Sort

    _____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    H
    I
    J
    K
    W
    X
    Y
    824
    351
    0.1
    825
    342
    0.1
    0
    826
    342
    0
    827
    341
    0.1
    0
    828
    339
    0.1
    0
    829
    338
    1
    0
    830
    338
    1
    0
    831
    338
    0.1
    0.1
    832
    338
    0.1
    0.1
    833
    338
    0.1
    0
    834
    338
    0.1
    0
    835
    337
    0.5
    0.1
    836
    337
    0.1
    0.1
    837
    337
    0.1
    0
    838
    337
    0
    0.1
    839
    336
    0.2
    0
    840
    335
    0.1
    0
    841
    334
    0
    0.1
    842
    333
    0.2
    0
    843
    332
    0.2
    0
    844
    332
    0.1
    0.1
    845
    332
    0.1
    0
    846
    331
    0.1
    0.1
    847
    331
    0.1
    0.1
    848
    329
    0.2
    0
    849
    329
    0.1
    0
    850
    326
    0.3
    0
    851
    326
    0.3
    0
    852
    326
    0.2
    0
    853
    326
    0.1
    0
    854
    324
    0.1
    0.1
    855
    324
    0.1
    0
    856
    319
    0.2
    0.1
    857
    318
    0.5
    0.1
    858
    316
    0.2
    0.1
    859
    279
    0.5
    0.1
    860
    232
    0.1
    0
    861
    230
    0.2
    0
    862
    215
    0
    0
    Worksheet: Sheet1

    Time .25secs

  10. #10
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Array Sort

    _____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    H
    I
    J
    K
    W
    X
    824
    351
    0.1
    825
    342
    0.1
    0
    826
    342
    0
    827
    341
    0.1
    0
    828
    339
    0.1
    0
    829
    338
    1
    0
    830
    338
    1
    0
    831
    338
    0.1
    0.1
    832
    338
    0.1
    0.1
    833
    338
    0.1
    0
    834
    338
    0.1
    0
    835
    337
    0.5
    0.1
    836
    337
    0.1
    0.1
    837
    337
    0.1
    0
    838
    337
    0
    0.1
    839
    336
    0.2
    0
    840
    335
    0.1
    0
    841
    334
    0
    0.1
    842
    333
    0.2
    0
    843
    332
    0.2
    0
    844
    332
    0.1
    0.1
    845
    332
    0.1
    0
    846
    331
    0.1
    0.1
    847
    331
    0.1
    0.1
    848
    329
    0.2
    0
    849
    329
    0.1
    0
    850
    326
    0.3
    0
    851
    326
    0.3
    0
    852
    326
    0.2
    0
    853
    326
    0.1
    0
    854
    324
    0.1
    0.1
    855
    324
    0.1
    0
    856
    319
    0.2
    0.1
    857
    318
    0.5
    0.1
    858
    316
    0.2
    0.1
    859
    279
    0.5
    0.1
    860
    232
    0.1
    0
    861
    230
    0.2
    0
    862
    215
    0
    0
    Worksheet: Sheet1

    Time 1.25secs

    Immediate Window output
    Code:
     1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 
    First procedure Call
     Running Copy 1 of routine.
      Sorted rows  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42  based on values in column 8
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 8,  2 3  , so now Rec Call 1
     Running Copy 2 of routine.
      Sorted rows  2 3  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 8,  6 7 8 9 10 11  , so now Rec Call 1
     Running Copy 2 of routine.
      Sorted rows  6 7 8 9 10 11  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 10,  6 7  , so now Rec Call 1
     Running Copy 3 of routine.
      Sorted rows  6 7  based on values in column 24
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 8,  12 13 14 15  , so now Rec Call 1
     Running Copy 2 of routine.
      Sorted rows  12 13 14 15  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 10,  13 14  , so now Rec Call 1
     Running Copy 3 of routine.
      Sorted rows  13 14  based on values in column 24
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 8,  20 21 22  , so now Rec Call 1
     Running Copy 2 of routine.
      Sorted rows  20 21 22  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 8,  23 24  , so now Rec Call 1
     Running Copy 2 of routine.
      Sorted rows  23 24  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 8,  25 26  , so now Rec Call 1
     Running Copy 2 of routine.
      Sorted rows  25 26  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 8,  27 28 29 30  , so now Rec Call 1
     Running Copy 2 of routine.
      Sorted rows  27 28 29 30  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 10,  27 28  , so now Rec Call 1
     Running Copy 3 of routine.
      Sorted rows  27 28  based on values in column 24
       Checking now for Dups in that last sorted list
    
    Found dups in last list column 8,  31 32  , so now Rec Call 1
     Running Copy 2 of routine.
      Sorted rows  31 32  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list, so now Rec Call 2 (Dups at list end case)
     Running Copy 2 of routine.
      Sorted rows  40 41 42  based on values in column 10
       Checking now for Dups in that last sorted list
    
    Found dups in last list, so now Rec Call 2 (Dups at list end case)
     Running Copy 3 of routine.
      Sorted rows  40 41 42  based on values in column 24
       Checking now for Dups in that last sorted list
    
    Found dups in last list, so now Rec Call 2 (Dups at list end case)
    You need more than 3 keys to complete sort



    See further tests from here
    http://www.excelfox.com/forum/showth...ll=1#post11055
    Last edited by DocAElstein; 03-14-2019 at 03:44 PM.

Similar Threads

  1. Replies: 19
    Last Post: 04-20-2019, 02:38 PM
  2. Replies: 1
    Last Post: 04-02-2019, 03:04 PM
  3. Testing functionalities
    By Admin in forum Test Area
    Replies: 1
    Last Post: 09-01-2016, 04:02 PM
  4. testing BBCode with conditional formatting
    By Admin in forum Test Area
    Replies: 0
    Last Post: 01-20-2016, 08:36 AM
  5. TESTING Column Letter test Sort Last Row
    By alansidman in forum Test Area
    Replies: 0
    Last Post: 10-24-2013, 07:14 PM

Posting Permissions

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