Appendix Thread. App Index Rws() Clms() Majic code line Codings for other Threads, Tables etc) TEST COPY

Sub TestieSimpleArraySort8() ( and Global variables and a required Function )

Global variables required. ( Must go at top of code module )

Code:

Option Explicit Dim Cms() As Variant, Rs() As Variant ' "Horizointal Column" Indicies , "Virtical row" Indicies Dim RngToSort As Range ' Test data range Dim arrOrig() As Variant ' This arrIndx() = Application.Index(arrOrig(), Rs(), Cms()) applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range

A required function

Code:

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 Do Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL Let lclm = (lclm - (1)) \ 26 Loop While lclm > 0 End Function Function FukOutChrWithDoWhile(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 FukOutChrWithDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & FukOutChrWithDoWhile 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 ' https://www.excelforum.com/tips-and-tutorials/1213798-all-sub-folder-and-file-list-from-vba-recursion-routine-explanation-and-method-comparison.html

Calling routine ( to call recursion routine in next post )

Code:

Sub TestieSimpleArraySort8() Rem 0 test data, worksheets info Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting") ' Dim RngToSort As Range Set RngToSort = WsS.Range("R23:W37") ' 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 Let arrIndx() = arrTS() Let arrOrig() = arrTS() ' This Application.Index(arrOrig(), Rs(), Cms()) applies the modified Rs() to the original unsorted data range. So we need an array to use constantly containing the original data range ' Call SimpleArraySort8(1, arrTS(), " 1 2 3 4 5 ", " 1 Asc 2 Asc 3 Asc") ' Column Indicies Let Cms() = Evaluate("=Column(" & CL(1) & ":" & CL(RngToSort.Columns.Count) & ")") Let Cms() = Evaluate("=Column(A:F)") ' Initial row indicies Let Rs() = Evaluate("=Row(1:" & RngToSort.Rows.Count & ")") ' test index RngToSort.Offset(-1, 0).Resize(1, UBound(Cms())).Value = Cms() RngToSort.Offset(0, -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs() RngToSort.Offset(RngToSort.Rows.Count, 0).ClearContents Let RngToSort.Offset(RngToSort.Rows.Count, 0).Value = Application.Index(arrTS(), Rs(), Cms()) ' Let RngToSort.Offset(RngToSort.Rows.Count, 0).Value = Application.Index(arrIndx(), Rs(), Cms()) RngToSort.Offset(RngToSort.Rows.Count, -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs() 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 ' For 5 rows , for example we will have " 1 2 3 4 5 " , for 15 rows " 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 " Call SimpleArraySort8(1, arrTS(), strIndcs, " 1 Desc 3 Asc 5 Asc") Rem 2 Output for easy of demo ' 2a RngToSort.Offset(0, RngToSort.Columns.Count).Clear Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrTS() Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow ' 2b VBA Range.Sort Method equivalent Dim TestRngSrt As Range: Set TestRngSrt = RngToSort.Offset(0, RngToSort.Columns.Count * 2) TestRngSrt.Clear Let TestRngSrt.Value = RngToSort.Value TestRngSrt.Sort Key1:=TestRngSrt.Columns("A:A"), order1:=xlDescending, Key2:=TestRngSrt.Columns("C:C"), order2:=xlAscending, Key3:=TestRngSrt.Columns("E:E"), order3:=xlAscending, MatchCase:=False TestRngSrt.Interior.Color = vbGreen End Sub

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_pdshr6
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ-
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg. 9iDVgy6wzct9iFBxma9zXI
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. 9iDLC2uEPRW9iFGvgk11nH
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg. 9iH3wvUZj3n9iHnpOxOeXa
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg. 9iGReNGzP4v9iHoeaCpTG8
https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I

Sub SimpleArraySort8(

recursion routine Called by routine ( Sub TestieSimpleArraySort8() ) from last post

Code:

' Main recursion routine below : Bubble Sorting in Arrays using multi columns values for sort criteria Sub SimpleArraySort8(ByVal CpyNo As Long, ByRef arrIndx() As Variant, ByVal strRws As String, ByVal strKeys As String) Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are If CopyNo = 1 Then Debug.Print "First procedure Call" Rem -1 from the supplied arguments, get all data needed in current bubble sort ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have If (2 * CopyNo) > UBound(Keys()) + 1 Then MsgBox Prompt:="You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level ' making an array from the " 3 4 5 6 " string is just for convenience later of getting the upper and lower row numbers Dim Rws() As String: Let Rws() = Split(Trim(strRws), " ", -1, vbBinaryCompare) ' We take the supplied sequential string 2 3 4 5 6 and make a 1 D array {1, 2, 3....} as it is a bit more conveniant to work with. Actually we only need the start and top numbers so we could do it with stinr manipulation instead Rem 1 Simple Bubble Sort Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop===================================== For rOuter = Rws(LBound(Rws())) To Rws(UBound(Rws()) - 1) ' For first row indicie to last but one row indicie Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To Rws(UBound(Rws())) ' from just above left hand through all the rest If GlLl = 0 Then ' We want Ascending list If IsNumeric(arrIndx(rOuter, Clm)) And IsNumeric(arrIndx(rInner, Clm)) Then ' Numeric case If CDbl(arrIndx(rOuter, Clm)) > CDbl(arrIndx(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 Let Temp = arrIndx(rOuter, Clm): Let arrIndx(rOuter, Clm) = arrIndx(rInner, Clm): Let arrIndx(rInner, Clm) = Temp Dim TempRs As Long Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs Else End If Else ' Non numeric case If UCase(CStr(arrIndx(rOuter, Clm))) > UCase(CStr(arrIndx(rInner, Clm))) Then Let Temp = arrIndx(rOuter, Clm): Let arrIndx(rOuter, Clm) = arrIndx(rInner, Clm): Let arrIndx(rInner, Clm) = Temp 'Dim TempRs As Long Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs Else End If End If ' End of numeric or text comparison Else ' GlLl is not 0 , so presumably we want Descending list If IsNumeric(arrIndx(rOuter, Clm)) And IsNumeric(arrIndx(rInner, Clm)) Then If CDbl(arrIndx(rOuter, Clm)) < CDbl(arrIndx(rInner, Clm)) Then Let Temp = arrIndx(rOuter, Clm): Let arrIndx(rOuter, Clm) = arrIndx(rInner, Clm): Let arrIndx(rInner, Clm) = Temp 'Dim TempRs As Long Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs Else End If Else ' non numeric case If UCase(CStr(arrIndx(rOuter, Clm))) < UCase(CStr(arrIndx(rInner, Clm))) Then Let Temp = arrIndx(rOuter, Clm): Let arrIndx(rOuter, Clm) = arrIndx(rInner, Clm): Let arrIndx(rInner, Clm) = Temp 'Dim TempRs As Long Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs Else End If End If ' End of numeric or text comparison End If ' End of Ascending or Descending example Next rInner ' --------------------------------------------------------------------- Next rOuter ' =========================================================================================== Debug.Print "Doing an arrIndx()" Let arrIndx() = Application.Index(arrOrig(), Rs(), Cms()) ' Captains Blog, Start Treck Debug.Print " Running Copy " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf ' Rem 3 Determine any duplicates in sort column values , and re run the routine to sort them by another column Let rOuter = Rws(LBound(Rws())) - 1 ' we look for duplicates in the current list, in the loop below we add 1 each time so _ it is necersarry to start 1 before, so that +1 the first time is the start row Let strRws = "" ' ready for use in duplicate search Do ' Loop down the last set of sorted rows ****************************************************| Let rOuter = rOuter + 1 ' next row number _ it was necersarry to start 1 before, so that +1 the first time is the start row If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates If Trim(UCase(CStr(arrIndx(rOuter, Clm)))) = Trim(UCase(CStr(arrIndx(rOuter + 1, Clm)))) Then ' case in duplicate rows Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line Else ' when we did not have a next duplicate, we may have a few already grouped If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now Rec Call 1" ' This is done for every duplicated value section, except if we have duplicates at the last lines Call SimpleArraySort8(CopyNo + 1, arrIndx(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates Let strRws = "" ' ready to try for another set of duplicates Else End If End If ' this is the end of the stuff in most situations... ' ...below section catches rows at the end that might need to be sorted. ......| If rOuter = UBound(arrIndx(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row Debug.Print "Found dups in last list, so now Rec Call 2 (Dups at list end case)" ' Rec Call 2 - only done for duplicates at end of list Call SimpleArraySort8(CopyNo + 1, arrIndx(), strRws, strKeys) Else End If '... ................................................................| Loop While rOuter <> Rws(UBound(Rws()) - 1) ' keep looking for Duplicates in next row**********| End Sub

Coding for this excelfox Post:
http://www.excelfox.com/forum/showth...ll=1#post11066

Code:

' Sub Call_Sub_Bubbles() ' Partially hard coded for ease of explanation ' data range info Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting") Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16") ' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8 Dim arrTS() As Variant ' array to be referred to in all recursion routines, initially the original data range Let arrTS() = RngToSort.Value ' Initial row indicies Let Rs() = Evaluate("=Row(1:6)") ' Dim strRows As String, Cnt As Long: Let strRows = " " For Cnt = 1 To 6 Let strRows = strRows & Rs(Cnt, 1) & " " Next Cnt ' we should have now strRows = " 1 2 3 4 5 6 " Call Bubbles(1, arrTS(), strRows, " 1 Asc 3 Asc 2 Asc ") ' Demo output Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrTS() End Sub ' Sub Bubbles(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String) Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc… If CopyNo = 1 Then Debug.Print "First procedure Call" Rem -1 from the supplied arguments, get all data needed in current bubble sort Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it 'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level Rem 1 Bubble sort Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop===================================== ' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1 For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 'For rOuter = 1 To 5 ' For first run Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(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(arsRef(), 2) Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(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 3 Preparation for possible recursion Call ' Catpains Blog Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below Let strRws = "" 'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1 For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates 'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces ) ' Now its time to organise a recursion run Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates Let strRws = "" ' ready to try for another set of duplicates Else End If ' we did not have more than one indicie in strRws so usually that's it for this loop End If '+++*** this would be end of loop for most cases ' ...below section catches rows at the end that might need to be sorted. ......| If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys) Else End If '... ................................................................| Next rOuter ' ************************************************************************** Debug.Print "Ending a copy, Copy level " & CopyNo & "" End Sub

Sub BubblesIndexIdeaWay As Sub Bubble , just replacing name in three places

Code:

' Sub Bubbles(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String) Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc… If CopyNo = 1 Then Debug.Print "First procedure Call" Rem -1 from the supplied arguments, get all data needed in current bubble sort Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it 'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level Rem 1 Bubble sort Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop===================================== ' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1 For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 'For rOuter = 1 To 5 ' For first run Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(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(arsRef(), 2) Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(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 3 Preparation for possible recursion Call ' Catpains Blog Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below Let strRws = "" 'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1 For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates 'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces ) ' Now its time to organise a recursion run Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates Let strRws = "" ' ready to try for another set of duplicates Else End If ' we did not have more than one indicie in strRws so usually that's it for this loop End If '+++*** this would be end of loop for most cases ' ...below section catches rows at the end that might need to be sorted. ......| If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys) Else End If '... ................................................................| Next rOuter ' ************************************************************************** Debug.Print "Ending a copy, Copy level " & CopyNo & "" End Sub

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg. 9hI1CQJMLLo9hWn2pGBeSS
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzkRujoMw9PblmXDQ14AaABAg. 9hJRnEjxQrd9hJoCjomNI2
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgzPZbG7OvUkh35nXDd4AaABAg. 9hJOZEEZa6p9hJqLC7El-w
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwUcEpm8u6ZW3uOHXx4AaABAg. 9hIlxxGY7t49hJsB2PWxC4
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyvDj6NWT1Gxyy2JyR4AaABAg. 9hIKlNPeqDn9hJskm92np6
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugwy7qx_kG9iUmMVO_F4AaABAg. 9hI2IGUdmTW9hJuyaQawqx
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgxesLhWNr_zNP0GUdh4AaABAg. 9hI1CQJMLLo9hJwTB9Jlob
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgyyQWYVP1OnCqavb-x4AaABAg
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=UgwJKKmExZ1FdZVDJf54AaABAg
https://www.youtube.com/watch?v=pkhazgI3LAo&lc=Ugz_p0kVGrLntPtYzCt4AaABAg
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

Sub BubblesIndexIdeaWay As Sub Bubble , just replacing name in three places

This intermadiate routine is simply Sub Bubbles(), with the name changed to Sub BubblesIndexIdeaWay(), and the two recursion Calling code lines changed from
Call Bubbles(CopyNo + 1, arsRef(), strRws, strKeys)
to
Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys)

Code:

' Sub BubblesIndexIdeaWay(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String) Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc… If CopyNo = 1 Then Debug.Print "First procedure Call" Rem -1 from the supplied arguments, get all data needed in current bubble sort Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it 'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level Rem 1 Bubble sort Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop===================================== ' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1 For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 'For rOuter = 1 To 5 ' For first run Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(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(arsRef(), 2) Let Temp = arsRef(rOuter, Clms): Let arsRef(rOuter, Clms) = arsRef(rInner, Clms): Let arsRef(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 3 Preparation for possible recursion Call ' Catpains Blog Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below Let strRws = "" 'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1 For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates 'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative If Trim(UCase(CStr(arsRef(rOuter, Clm)))) = Trim(UCase(CStr(arsRef(rOuter + 1, Clm)))) Then ' case in duplicate rows Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces ) ' Now its time to organise a recursion run Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates Let strRws = "" ' ready to try for another set of duplicates Else End If ' we did not have more than one indicie in strRws so usually that's it for this loop End If '+++*** this would be end of loop for most cases ... but Oh Fuck 'Oh Fuck' ...below section catches rows at the end that might need to be sorted. ......| If rOuter = UBound(arsRef(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list Call BubblesIndexIdeaWay(CopyNo + 1, arsRef(), strRws, strKeys) Else End If '... ................................................................| Next rOuter ' ************************************************************************** Debug.Print "Ending a copy, Copy level " & CopyNo & "" End Sub

Original test data range , ( B11:E16 )

_Row\^Col
A

B

C

D

E

10

11

1

5

3
a

12

9

9

9
b

13

1

4

2
c

14

8

8

8
d

15

1

3

2
e

16

7

7

7
f

Worksheet: Sorting

Added initial row and column indicees

_Row\^Col
A

B

C

D

E

10

1

2

3

4

11

1

1

5

3
a

12

2

9

9

9
b

13

3

1

4

2
c

14

4

8

8

8
d

15

5

1

3

2
e

16

6

7

7

7
f

Worksheet: Sorting

_Row\^Col	B	C	D	E
10
11	1	5	3	a
12	9	9	9	b
13	1	4	2	c
14	8	8	8	d
15	1	3	2	e
16	7	7	7	f

_Row\^Col	A	B	C	D	E
10		1	2	3	4
11	1	1	5	3	a
12	2	9	9	9	b
13	3	1	4	2	c
14	4	8	8	8	d
15	5	1	3	2	e
16	6	7	7	7	f

Sub Call_Sub_BubblesIndexIdeaWay()

Calling routine required for previous Post and following Post

Code:

Sub Call_Sub_BubblesIndexIdeaWay() ' Partially hard coded for ease of explanation ' data range info Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting") Dim RngToSort As Range: Set RngToSort = WsS.Range("B11:E16") ' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8 Dim arrTS() As Variant ' This is somewhat redundant for this version and could be replaced by arrOrig() Let arrTS() = RngToSort.Value ' Index idea variables Let arrOrig() = arrTS() Let arrIndx() = arrTS() Let Cms() = Evaluate("=Column(A:D)") ' Convenient way to get Let Rs() = Evaluate("=Row(1:6)") ' Initial row indicies ' Add initial indicies Let RngToSort.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed Let RngToSort.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed ' Initial row indicies from full original range´of rows Dim strRows As String, Cnt As Long: Let strRows = " " For Cnt = 1 To 6 Let strRows = strRows & Rs(Cnt, 1) & " " Next Cnt ' we should have now strRows = " 1 2 3 4 5 6 " Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc 2 Asc ") ' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc ") ' Call BubblesIndexIdeaWay(1, arrIndx(), strRows, " 1 Asc 3 Asc ") ' Demo output Dim RngDemoOutput As Range: Set RngDemoOutput = WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count) ' Let WsS.Range("B31").Resize(RngToSort.Rows.Count, RngToSort.Columns.Count).Value = arrIndx() Let RngDemoOutput = arrIndx() Let RngDemoOutput.Offset(-1, 0).Resize(1, 4).Value = Cms(): RngToSort.Offset(-1, 0).Resize(1, 4).Font.Color = vbRed Let RngDemoOutput.Offset(0, -1).Resize(6, 1).Value = Rs(): RngToSort.Offset(0, -1).Resize(6, 1).Font.Color = vbRed End Sub

Recursion routine for this post:
http://www.excelfox.com/forum/showth...ll=1#post11078

Code:

Sub BubblesIndexIdeaWay(ByVal CpyNo As Long, ByRef arsRef() As Variant, ByVal strRws As String, ByVal strKeys As String) Dim CopyNo As Long: Let CopyNo = CpyNo ' On every recurssion run this will be increased by the Rec Call. This will be a local variable indicating the level down in recursion - I increase it by 1 at every Rec Call, that is to say each Rec Call gets given CopyNo+1 - during a long tunnel down, the number at this pint will keep increasing to reflect how far down we are. This ensures we then have the correct value place at the start of any newly starting copy of the recursion routine, since the first copy of the recursion routine pauses and starts the second copy of the recursion routine, the second copy of the recursion routine pauses and starts the third copy of the recursion routine ….. etc… If CopyNo = 1 Then Debug.Print "First procedure Call" Rem -1 from the supplied arguments, get all data needed in current bubble sort Dim Keys() As String: Let Keys() = Split(Replace(Trim(strKeys), " ", " ", 1, -1, vbBinaryCompare), " ", -1, vbBinaryCompare) '' The extra replace allows for me seperating with one or two spaces - the following would do if I only used one space always Split(Trim(strKeys), " ", -1, vbBinaryCompare) ' this will be an array twice as big as the number of keys that we have ...... ' Column for this level sort , and Ascending or Descending - both determined from the supplied forth arguments and the column/ copy number If (2 * CopyNo) > UBound(Keys()) + 1 Then Debug.Print "You need more than " & (UBound(Keys()) + 1) / 2 & " keys to complete sort": Exit Sub ' case we have less keys then we need to sort, are array has twice as many elements as we have supplied keys since we have a key and whether it needs to get bigger or smaller , and array is from 0 so must add 1 to ubound then half it get the key number we gave. We come here if the last column we gave as a Key had duplicates in it 'Dim GlLl As Long: If Keys((CopyNo * 2) - 1) = "Desc" Then Let GlLl = 1 ' (CopyNo * 2) - 1) gives as we go down levels 1 3 5 7 etc We're seeing if we had Desc for this column Dim Clm As Long: Let Clm = CLng(Keys((CopyNo * 2) - 2)) ' ' (CopyNo * 2) - 2) gives as we go down levels 0 2 4 6 etc We are picking out the supplied column to sort by for each level Rem 1 Bubble sort Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop===================================== ' For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' THIS WOULD ONLY WORK FOR Copy No 1 For first row indicie to last but one row indicie - I could do this for copy 1 For rOuter = Left(Trim(strRws), InStr(1, Trim(strRws), " ", vbBinaryCompare) - 1) To Right(Trim(strRws), Len(Trim(strRws)) - InStrRev(Trim(strRws), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 'For rOuter = 1 To 5 ' For first run Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To Rs(UBound(Rs(), 1), 1) ' from just above left hand through all the rest If CDbl(arsRef(rOuter, Clm)) > CDbl(arsRef(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 Let Temp = arrIndx(rOuter, Clm): Let arrIndx(rOuter, Clm) = arrIndx(rInner, Clm): Let arrIndx(rInner, Clm) = Temp Dim TempRs As Long Let TempRs = Rs(rOuter, 1): Let Rs(rOuter, 1) = Rs(rInner, 1): Let Rs(rInner, 1) = TempRs Else End If Next rInner ' ----------------------------------------------------------------------- Next rOuter ' ==================End=Rem 1=============================================================== Rem 2 Let arrIndx() = Application.Index(arrOrig(), Rs(), Cms()) Rem 3 Preparation for possible recursion Call ' Catpains Blog Debug.Print " Running Copy No. " & CopyNo & " of routine." & vbCr & vbLf & " Sorted rows " & strRws & " based on values in column " & Clm & vbCr & vbLf & " Checking now for Dups in that last sorted list" & vbCr & vbLf Dim tempStr As String: Let tempStr = strRws ' Need this bodge because I set strRws="" below Let strRws = "" 'For rOuter = Rs(LBound(Rs(), 1), 1) To Rs(UBound(Rs(), 1), 1) - 1 ' Only valis for first Copy No 1 For rOuter = Left(Trim(tempStr), InStr(1, Trim(tempStr), " ", vbBinaryCompare) - 1) To Right(Trim(tempStr), Len(Trim(tempStr)) - InStrRev(Trim(tempStr), " ", -1, vbBinaryCompare)) - 1 ' ImmediteWindowToHelpGetAtStuff.JPG : https://imgur.com/yGqmYSu : http://www.eileenslounge.com/viewtopic.php?f=27&t=16407&p=247121#p247121 If strRws = "" Or InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then Let strRws = " " & rOuter & " " ' case starting again to get duplicates 'If strRws = "" Or Trim(strRws) = rOuter - 1 Then Let strRws = " " & rOuter & " " ' alternative If Trim(UCase(CStr(arrIndx(rOuter, Clm)))) = Trim(UCase(CStr(arrIndx(rOuter + 1, Clm)))) Then ' case in duplicate rows Let strRws = strRws & rOuter + 1 & " " ' we building a list like " 4 5 6 " based on if the next is a duplicate value, which is determined by the last line Else ' without the last condition met, we might have the end of a group duplicate rows, in which case it would be time to organise a recursion run so ..... we check for this situation needing a recursion run If Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case we have at least 2 duplicates but have hit end of that list ( we have at least one space between indices, like " 3 4 " , " 6 7 8" etc.. ---- this , " 2 " , on the other hand, would would not have a space after trimming off the end spaces ) ' Now its time to organise a recursion run Debug.Print "Found dups in last list column " & Clm & ", " & strRws & " , so now main Rec Call " ' This is done for every duplicated Call BubblesIndexIdeaWay(CopyNo + 1, arrIndx(), strRws, strKeys) ' Rec Call 1 I need to sort the last duplicates Let strRws = "" ' ready to try for another set of duplicates Else End If ' we did not have more than one indicie in strRws so usually that's it for this loop End If '+++*** this would be end of loop for most cases ... but Oh Fuck 'Oh Fuck' ...below section catches rows at the end that might need to be sorted. ......| If rOuter = UBound(arrIndx(), 1) - 1 And Not InStr(1, Trim(strRws), " ", vbBinaryCompare) = 0 Then ' case of duplicates in last row Debug.Print "Found dups in last rows of last list, so now Rec Call at end of loop (Dups at list end case)" ' loop end rec call - only done for duplicates at end of list Call BubblesIndexIdeaWay(CopyNo + 1, arrIndx(), strRws, strKeys) Else End If '... ................................................................| Next rOuter ' ************************************************************************** Debug.Print "Ending a copy, Copy level " & CopyNo & "" End Sub

2 Attachment(s)

Some Killing File tests / What order does Dir(with wild cards) find stuff

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
http://www.eileenslounge.com/viewtopic.php?f=30&t=41784
http://www.eileenslounge.com/viewtopic.php?p=323966#p323966
http://www.eileenslounge.com/viewtopic.php?p=323959#p323959
http://www.eileenslounge.com/viewtopic.php?p=323960#p323960
http://www.eileenslounge.com/viewtopic.php?p=323894#p323894
http://www.eileenslounge.com/viewtopic.php?p=323843#p323843
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa6BSa173Z
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa6-64Xpgl
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa5ms39yjd
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa5ZXJwRCM
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa4Pr15NUt
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABa4I83JelY
https://www.youtube.com/watch?v=C43btudYyzA&lc=Ugyf349Ue6_4umFfNUB4AaABAg. 8mjgPNoTt_HABa3tnAjhZU
https://www.youtube.com/watch?v=C43btudYyzA&lc=Ugyf349Ue6_4umFfNUB4AaABAg. 8mjgPNoTt_HABa3KswxL3c
https://www.youtube.com/watch?v=suUqEo3QWus&lc=UgyBXFxnVWT3pqtdqPx4AaABAg
https://www.youtube.com/watch?v=suUqEo3QWus&lc=Ugi53h84LUm5bHgCoAEC.7-H0Z7-COoGABZFQ8vjEvY
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABZ8N9O-O8p
http://www.eileenslounge.com/viewtopic.php?p=323547#p323547
http://www.eileenslounge.com/viewtopic.php?p=323516#p323516
http://www.eileenslounge.com/viewtopic.php?p=323517#p323517
http://www.eileenslounge.com/viewtopic.php?p=323449#p323449
http://www.eileenslounge.com/viewtopic.php?p=323226#p323226
http://www.eileenslounge.com/viewtopic.php?f=25&t=41702&p=323150#p323150
http://www.eileenslounge.com/viewtopic.php?p=323085#p323085
http://www.eileenslounge.com/viewtopic.php?p=322955#p322955
http://www.eileenslounge.com/viewtopic.php?f=30&t=41659
https://www.youtube.com/watch?v=suUqEo3QWus&lc=Ugi53h84LUm5bHgCoAEC.7-H0Z7-COoGABZFQ8vjEvY
https://www.youtube.com/watch?v=3t8Mk4URi6g&lc=UgzoakhRXOsCaoRm_Nd4AaABAg. 8xzeMdC8IOGABZ8N9O-O8p
https://www.youtube.com/watch?v=C43btudYyzA&lc=UgxREWxgx2z2Lza_0st4AaABAg
https://www.youtube.com/watch?v=C43btudYyzA&lc=UgyikSWvlxbWS24NBeR4AaABAg
https://www.youtube.com/watch?v=C43btudYyzA&lc=UgwNiH4hhyrd2UjDK8d4AaABAg
https://www.youtube.com/watch?v=C43btudYyzA&lc=Ugyf349Ue6_4umFfNUB4AaABAg. 8mjgPNoTt_HAAf952WoUti
https://www.youtube.com/watch?v=hz4vb48wzMM&lc=Ugy2N3gvXBNrvWpojqR4AaABAg
http://www.eileenslounge.com/viewtopic.php?p=322462#p322462
http://www.eileenslounge.com/viewtopic.php?p=322356#p322356
http://www.eileenslounge.com/viewtopic.php?p=321984#p321984
https://eileenslounge.com/viewtopic.php?f=30&t=41610
https://eileenslounge.com/viewtopic.php?p=322176#p322176
https://eileenslounge.com/viewtopic.php?p=322238#p322238
https://eileenslounge.com/viewtopic.php?p=322270#p322270
https://eileenslounge.com/viewtopic.php?p=322300#p322300
http://www.eileenslounge.com/viewtopic.php?p=322150#p322150
http://www.eileenslounge.com/viewtopic.php?p=322111#p322111
http://www.eileenslounge.com/viewtopic.php?p=322086#p322086
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

2 Attachment(s)

Dir Order

Here is where we left off in the last post

HTML Code:

Folder used is F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder Folder First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*) is AForthThirdAfterwb.xlsx Use 1 in loop of unargumented Dir gives SecondFirstAfterwb.xlsx Use 2 in loop of unargumented Dir gives ThirdSecondAfterwb.xlsx

here is what it looks like in the explorer window:
ExpOrder1.JPG : https://imgur.com/OfQfHeH

I can move the order pysically in the explorer window, by selecting and dragging the file position virtically, ( and I hit the refresh thing , just in case that should influence anything )
ExpOrder2.JPG : https://imgur.com/AlV1MdB
The routine, Sub DirOrder() , then seems to give the same results

HTML Code:

Folder used is F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder Folder First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*) is AForthThirdAfterwb.xlsx Use 1 in loop of unargumented Dir gives SecondFirstAfterwb.xlsx Use 2 in loop of unargumented Dir gives ThirdSecondAfterwb.xlsx

I can do this:
ExpOrder3a.JPG : https://imgur.com/RBSa9Ou
ExpOrder3a.JPG : https://imgur.com/2OVsguZ
Once again I get the same alphabetical ordering in the Dir found order output

i can play around with this:
ExpOrder4.JPG : https://imgur.com/6FbYQgp
or this
Stack by change date.jpg : https://imgur.com/YIrTxpp , https://imgur.com/ht887FU , https://imgur.com/lHMcUjA
Attachment 2226
Once again I get the same alphabetical ordering in the Dir found order output

I made this d_xlsm_file.xlsm , and this ,c_xls_file.xls , and pit it in the foilder, Folder
A xlsm and xls.JPG : https://imgur.com/w9gyRxj
Attachment 2225
here is part of my Immediate window output

HTML Code:

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*) is AForthThirdAfterwb.xlsx Use 1 in loop of unargumented Dir gives c_xls_file.xls Use 2 in loop of unargumented Dir gives d_xlsm_file.xlsm

I need to increase my loop count, Cnt , to 4 to getting total all 5 files. But doing this is likely to get a bit tedious as I comtinue experiments with a different number of files in various folders. So I will change my coding, at the loop section, to a more typical type of loop used iin such a Dir __ file finding code: Usually something like this is done, so that the loop keeps going as long as Dir __ finds files

Code:

‘ First use of Dir with full path and file name argument ‘ strWB = "F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*" ‘ Wild card to get all Excel Files ‘ File = Dir(strWB) ‘ ‘ ‘ Loop for all files meeting search string criteria, ( all Excel files in this example ) Do ' '_- I want to keep going in a Loop while I still get a file name returned by Dir Dim Cnt As Long: Let Cnt = Cnt + 1 File = Dir: Debug.Print "Use " & Cnt & " in loop of unargumented Dir gives """ & File & """" Loop While File <> "" '_- I want to keep going in a Loop while I still get a file name returned by Dir

Here is the full coding, http://www.excelfox.com/forum/showth...ll=1#post11108 , which gives for the last example:

HTML Code:

F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder Folder First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\*.xls*) is AForthThirdAfterwb.xlsx Use 1 in loop of unargumented Dir gives "c_xls_file.xls" Use 2 in loop of unargumented Dir gives "d_xlsm_file.xlsm" Use 3 in loop of unargumented Dir gives "SecondFirstAfterwb.xlsx" Use 4 in loop of unargumented Dir gives "ThirdSecondAfterwb.xlsx" Use 5 in loop of unargumented Dir gives ""

I can change the serach criteria from strWB & "*.xls*" to strWB & "*" and it has no effect

i added a .jpg pic, ( Add a jpg.JPG : https://imgur.com/XkXskiL ) , and the listing had it in the aplhabetical order :

Code:

First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\Kill Stuff\Folder\*) is AForthThirdAfterwb.xlsx Use 1 in loop of unargumented Dir gives "c_xls_file.xls" Use 2 in loop of unargumented Dir gives "d_xlsm_file.xlsm" Use 3 in loop of unargumented Dir gives "SecondFirstAfterwb.xlsx" Use 4 in loop of unargumented Dir gives "Stack by change date .JPG" Use 5 in loop of unargumented Dir gives "ThirdSecondAfterwb.xlsx" Use 6 in loop of unargumented Dir gives ""

I use the last routine in the form to allow user selection of the folder to search for files
http://www.excelfox.com/forum/showth...ll=1#post11108. I looked at some arbritrary folders, - once again alphabetical order seems to come out:

Code:

Folder used is F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery wbSheetMakerClsdWbADOMsQueery First got by Dir(F:\Excel0202015Jan2016\ExcelForum\wbSheetMakerClsdWbADOMsQueery\*) is 83DB8900 Use 1 in loop of unargumented Dir gives "aaa.xlsm" Use 2 in loop of unargumented Dir gives "Amar321.xls.xlsx" Use 3 in loop of unargumented Dir gives "ApparantlyApparantIs_Change.JPG" Use 4 in loop of unargumented Dir gives "Aufzeichnen.JPG" Use 5 in loop of unargumented Dir gives "Book1.xls" Use 6 in loop of unargumented Dir gives "Book1.xlsm.zip" Use 7 in loop of unargumented Dir gives "CA930CD8.tmp" Use 8 in loop of unargumented Dir gives "ClosedWorkbook.xlsm" Use 9 in loop of unargumented Dir gives "CopyASheet.JPG" Use 10 in loop of unargumented Dir gives "CresssieFiles.JPG" Use 11 in loop of unargumented Dir gives "DB2IssJfürELProAbDec2014.xlsm" Use 12 in loop of unargumented Dir gives "EFFldr.xlsm" Use 13 in loop of unargumented Dir gives "EFldr1_1 Download.JPG" Use 14 in loop of unargumented Dir gives "Eileens Fldr.zip" Use 15 in loop of unargumented Dir gives "EileensFldr Contents Copy.JPG" Use 16 in loop of unargumented Dir gives "EileensFldr Contents Paste.JPG" Use 17 in loop of unargumented Dir gives "EileensFldr Make Empty Folder.JPG" Use 18 in loop of unargumented Dir gives "EileensFldr zip Download.JPG" Use 19 in loop of unargumented Dir gives "EileensFldr.zip" Use 20 in loop of unargumented Dir gives "EileensFolderExplainedOutput.JPG" Use 21 in loop of unargumented Dir gives "Example Folder and Macro File in same Folder.JPG" Use 22 in loop of unargumented Dir gives "FBandData.xlsm" Use 23 in loop of unargumented Dir gives "FBandDataNorie.xlsm" Use 24 in loop of unargumented Dir gives "FBandDataNorie.xlsx" Use 25 in loop of unargumented Dir gives "FormulaBarClosedWB.JPG" Use 26 in loop of unargumented Dir gives "GetData_ClosedBook+LINKS.xlsx" Use 27 in loop of unargumented Dir gives "GetData_ClosedBook.xls" Use 28 in loop of unargumented Dir gives "HimanshuktwCode.JPG" Use 29 in loop of unargumented Dir gives "KissMyClosedWB.JPG" Use 30 in loop of unargumented Dir gives "Mappe2.xlsm" Use 31 in loop of unargumented Dir gives "MazanDikCollectionWonk.xlsm" Use 32 in loop of unargumented Dir gives "mellowtangSummarySheets.xlsm" Use 33 in loop of unargumented Dir gives "MsQueerOptions.JPG" Use 34 in loop of unargumented Dir gives "myFileToClose.xlsm" Use 35 in loop of unargumented Dir gives "MyNewWorkbook.xlsx" Use 36 in loop of unargumented Dir gives "MySameFolder.JPG" Use 37 in loop of unargumented Dir gives "NeuProAktuelleMakros.xlsm" Use 38 in loop of unargumented Dir gives "NormalThisWorkbookCodeModule.JPG" Use 39 in loop of unargumented Dir gives "NutritionalValues2016.xlsx" Use 40 in loop of unargumented Dir gives "OnlyGets8810RowsInAQuerrListObjectTableThingyAnyways.JPG" Use 41 in loop of unargumented Dir gives "Plop.xlsm" Use 42 in loop of unargumented Dir gives "poo.xlsm" Use 43 in loop of unargumented Dir gives "RudyMSRAllSubFldrsFndRep.xlsm" Use 44 in loop of unargumented Dir gives "Sample.zip" Use 45 in loop of unargumented Dir gives "SchemaIniErrorPipe.JPG" Use 46 in loop of unargumented Dir gives "SrangeThisWorkbookCodeModule.JPG" Use 47 in loop of unargumented Dir gives "StopClosing.xlsm" Use 48 in loop of unargumented Dir gives "Summary sheet.xlsm" Use 49 in loop of unargumented Dir gives "template test.xlsm" Use 50 in loop of unargumented Dir gives "Top100MsQuery.JPG" Use 51 in loop of unargumented Dir gives "ViskasVerticalsMaster dataMjoza.xlsm" Use 52 in loop of unargumented Dir gives "wb2.csv" Use 53 in loop of unargumented Dir gives "wb2.xlsm" Use 54 in loop of unargumented Dir gives "wb2.xlsx" Use 55 in loop of unargumented Dir gives "WBAccessTimeTestData.xlsx" Use 56 in loop of unargumented Dir gives "WBAccestTimeTest.xlsm" Use 57 in loop of unargumented Dir gives "wbCodes.xlsb" Use 58 in loop of unargumented Dir gives "wbCodes.xlsm" Use 59 in loop of unargumented Dir gives "WBOpenRenameKlaredog.xls" Use 60 in loop of unargumented Dir gives "WBOpenRenameKlaredog.xlsm" Use 61 in loop of unargumented Dir gives "Wb_with_5Sheets_4Worksheets.xlsm" Use 62 in loop of unargumented Dir gives "WillyWonks.JPG" Use 63 in loop of unargumented Dir gives "workbook2.xlsm" Use 64 in loop of unargumented Dir gives "WorkbookOpenMsgBox.JPG" Use 65 in loop of unargumented Dir gives "WorksheetNames.JPG" Use 66 in loop of unargumented Dir gives "Worksheet_Change.JPG" Use 67 in loop of unargumented Dir gives ""

Note that a file named as a number comes first in the list, as is consitant with Excel regarding text as "larger" than a number in sorting things http://www.eileenslounge.com/viewtop...=32154#p249178

Up until now, all tests were done on an old Lap top using Vista operating system. I rechecked on a newer machine uisng Windows 7. I get the same results

"wbCodes.xlsm" : https://app.box.com/s/gfuintgifu1hgw5nap3jriz2x8mp911x ( Sub DirOrder() is here )
folder, "Folder" : https://app.box.com/s/vmmzeboetkt07ocggbx6p8lkurmp5wca
"wbCodes.xls" : https://app.box.com/s/gmdne53vehhuc6lvz3vfgyxqmwy07xlz ( Sub DirOrder() is here )