Just testing. Testing some sort routines. No reply needed

[DocAElstein]

Intermediate step coding for this post:
http://www.excelfox.com/forum/showth...ll=1#post11075

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

'
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
            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 ' ==========================================================================================

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