Just testing. Testing some sort routines. No reply needed

**DocAElstein** · 02-17-2019, 04:11 PM

**DocAElstein** · 02-17-2019, 11:04 PM

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

**DocAElstein** · 03-10-2019, 09:23 PM

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
'

**DocAElstein** · 03-11-2019, 02:27 AM

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

**DocAElstein** · 03-11-2019, 02:34 AM

_____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	H	J	L	N	P	R	T	V	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

**DocAElstein** · 03-11-2019, 02:36 AM

Results from Sub ReorgBy3Criteria()

_____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	H	J	L	N	P	R	T	V	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

**DocAElstein** · 03-11-2019, 02:40 AM

Results from Sub CallArraySort()

_____ Workbook: ProAktuellex8600x2Sort1.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	H	J	L	N	P	R	T	V	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

**DocAElstein** · 03-11-2019, 12:02 PM

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	J	X
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

**DocAElstein** · 03-11-2019, 09:43 PM

Range.Sort

_____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	H	J	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 .25secs

**DocAElstein** · 03-11-2019, 09:56 PM

Array Sort

_____ Workbook: ProAktuellex8600x2SortTime.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	H	J	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