Final Demo of recursion array sort on multi coliumns
Take an example,
A list of Foods, their name in first column and a few other things like calories(Kcal) and Salt content in other columns
First I want to sort to group similar products (based on alphabetical order, but ascending or descending is not important) - This will be sorting on column 1 values
Within similar food types, I want to list them in an order of how healthy they might be, ( or at least in the order of least unhealthy ) .
Most important would be order starting with lowest Kcal.
After that for similar products with similar Kcal , we would consider the minimum salt content as likely to be the less unhealthy.
This might be our list
_____ ( Using Excel 2007 32 bit )
| Row\Col |
R |
S |
T |
U |
V |
W |
|---|
22 |
Food Product |
Was S22 |
Kcal |
Was U22 |
Salt |
Was W22 |
23 |
Crisps |
Was S23 |
500 |
Was U23 |
0.7 |
Was W23 |
24 |
Beer |
Was S24 |
200 |
Was U24 |
0.1 |
Was W24 |
25 |
Wine |
Was S25 |
150 |
Was U25 |
0.15 |
Was W25 |
26 |
Beer |
Was S26 |
200 |
Was U26 |
0.07 |
Was W26 |
27 |
beer |
Was S27 |
220 |
Was U27 |
0.2 |
Was W27 |
28 |
Beer |
Was S28 |
210 |
Was U28 |
0.06 |
Was W28 |
29 |
Wine |
Was S29 |
160 |
Was U29 |
0.04 |
Was W29 |
30 |
wiNe |
Was S30 |
150 |
Was U30 |
0.03 |
Was W30 |
31 |
Crisps |
Was S31 |
502 |
Was U31 |
2 |
Was W31 |
32 |
Onion Ringes |
Was S32 |
480 |
Was U32 |
1 |
Was W32 |
33 |
Onion Ringes |
Was S33 |
490 |
Was U33 |
1.5 |
Was W33 |
34 |
Crisps |
Was S34 |
502 |
Was U34 |
1.5 |
Was W34 |
35 |
CRISPS |
Was S35 |
500 |
Was U35 |
1.1 |
Was W35 |
36 |
Wine |
Was S36 |
170 |
Was U36 |
0.1 |
Was W36 |
37 |
Crisps |
Was S37 |
500 |
Was U37 |
3 |
Was W37 |
Here is a demo Calling test routine
Code:
Sub TestieSimpleArraySort6()
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
' Call SimpleArraySort6(1, arrTS(), " 1 2 3 4 5 ", " 1 Asc 2 Asc 3 Asc")
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 SimpleArraySort6(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
TestRngSrt.Interior.Color = vbGreen
End Sub
'
That above routine uses the test range R23:W37 above and feeds that to the main recursion routine below in the next post. The demo routine also does the VBA Range.Sort equivalent code line
Final Main recursion Array sort using multi columns routine below
Code:
'
' Main recursion routine below : Bubble Sorting in Arrays using multi columns values for sort criteria
Sub SimpleArraySort6(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
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(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
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
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
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
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
' Captains Blog, just fo info
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(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 ' 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 SimpleArraySort6(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
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(arsRef(), 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 SimpleArraySort6(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... ................................................................|
Loop While rOuter <> Rws(UBound(Rws()) - 1) ' keep looking for Duplicates in next row**********|
End Sub
Typical results in the next post:
Code to simulate Click on Office Clipboard Clear All Button
Code in support of these Threads:
http://www.excelfox.com/forum/showth...1018#post11018
http://www.eileenslounge.com/viewtopic.php?f=30&t=31849
https://stackoverflow.com/questions/...ently-on-the-c
https://stackoverflow.com/questions/...60767#54960767
Code:
Private Type POINTAPI
x As Long: Y As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If
Dim hwndClip As LongPtr
Dim hwndScrollBar As LongPtr
Dim lngPtr As LongPtr
#Else
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Dim hwndClip As Long
Dim hwndScrollBar As Long
#End If
Const GW_CHILD = 5
Const S_OK = 0
Sub ClearOffPainBouton() 'OhFolloks
'Application.DisplayClipboardWindow = True
Dim tRect1 As RECT, tRect2 As RECT
Dim tPt As POINTAPI
Dim oIA As IAccessible
Dim vKid As Variant
Dim lResult As Long
Dim i As Long
Static bHidden As Boolean
Dim MyPain As String 'COMsOLEwollupsActivelyEmmbeddedXratedObjectHookMyBoutonOhFolloks
If CLng(Val(Application.Version)) <= 11 Then
Let MyPain = "Task Pane"
Else
Let MyPain = "Office Clipboard"
End If
If CommandBars(MyPain).Visible = False Then
bHidden = True
CommandBars(MyPain).Visible = True
Application.OnTime Now + TimeValue("00:00:01"), "ClearOffPainBouton": Exit Sub
End If
Let hwndClip = FindWindowEx(Application.hWnd, 0, "EXCEL2", vbNullString)
Let hwndClip = FindWindowEx(hwndClip, 0, "MsoCommandBar", CommandBars(MyPain).NameLocal)
Let hwndClip = GetNextWindow(hwndClip, GW_CHILD)
Let hwndScrollBar = GetNextWindow(GetNextWindow(hwndClip, GW_CHILD), GW_CHILD)
If hwndClip And hwndScrollBar Then
GetWindowRect hwndClip, tRect1
GetWindowRect hwndScrollBar, tRect2
BringWindowToTop Application.hWnd
For i = 0 To tRect1.Right - tRect1.Left Step 50
tPt.x = tRect1.Left + i: tPt.Y = tRect1.Top - 10 + (tRect2.Top - tRect1.Top) / 2
#If VBA7 And Win64 Then
CopyMemory lngPtr, tPt, LenB(tPt)
Let lResult = AccessibleObjectFromPoint(lngPtr, oIA, vKid)
#Else
Let lResult = AccessibleObjectFromPoint(tPt.x, tPt.Y, oIA, vKid)
#End If ' ##### avec moi si vou ple La légende du bouton
If InStr("Clear All Borrar todo Effacer tout Alle löschen La légende du bouton", oIA.accName(vKid)) Then
Call oIA.accDoDefaultAction(vKid): CommandBars(MyPain).Visible = Not bHidden: bHidden = False: Exit Sub
End If
DoEvents
Next i
End If
Let CommandBars(MyPain).Visible = Not bHidden
MsgBox "Unable to clear the Office Clipboard"
End Sub
Sub TestVersion() ' Rory Archibald 2015
MsgBox prompt:=ExcelVersion
MsgBox prompt:=CLng(Val(Application.Version))
End Sub
Private Function ExcelVersion() As String
Dim Temp As String
'On Error Resume Next
#If Mac Then
Select Case CLng(Val(Application.Version))
Case 11: Temp = "Excel 2004"
Case 12: Temp = "Excel 2008" ' this should NEVER happen!
Case 14: Temp = "Excel 2011"
Case 15: Temp = "Excel 2016 (Mac)"
Case Else: Temp = "Unknown"
End Select
#Else
Select Case CLng(Val(Application.Version))
Case 9: Temp = "Excel 2000"
Case 10: Temp = "Excel 2002"
Case 11: Temp = "Excel 2003"
Case 12: Temp = "Excel 2007"
Case 14: Temp = "Excel 2010"
Case 15: Temp = "Excel 2013"
Case 16: Temp = "Excel 2016 (Windows)"
Case Else: Temp = "Unknown"
End Select
#End If
#If Win64 Then
Temp = Temp & " 64 bit"
#Else
Temp = Temp & " 32 bit"
#End If
ExcelVersion = Temp
End Function
Early Binding and Later Late Binding fo data objects
Coding in support of this post:
http://www.excelfox.com/forum/showth...ll=1#post11018
Code:
Sub MSFORMS_Early_Copy_and_Later_Late_Binding_Paste()
Rem 1 Late Binding
Dim DtaObj As MSForms.DataObject ' RefMSFORMS.JPG : https://imgur.com/8zKpyr2
Set DtaObj = New MSForms.DataObject
'Dim DtaObj As New MSForms.DataObject
Rem 1 ' Arbritrary Excel range values copy
Let Range("A1").Value = "CellA1": Let Range("A2").Value = "CellA2": Let Range("B1").Value = "CellB1": Let Range("B2").Value = "CellB2"
Rem 2 Clipboard Data object stuff - get the long string that is held in some clipboards
Range("A1:B2").Copy ' ' This seems to fill Excel, Windows and Office Clipboards http://www.eileenslounge.com/viewtopic.php?f=30&t=31849&p=246889#p246887
' Get some string version from some clipboard using a DataObject method
' Let Application.CutCopyMode = False ' generally speaking these two code lines will not clear the Windows Clipboards,
' Call ClearOffPainBouton ' but they do for the case of a range copy having put them in. So we can't do these here
DtaObj.GetFromClipboard ' ' This is filling a regisrre and possibly sometimes setting referrences that may prevent other things being done, or put them in a Queue, bit most likely to put a spanner in the works
Let Application.CutCopyMode = False
Call ClearOffPainBouton
' Range("A1:B2").Clear ' ' This will cause us to fail .. very strange .. this could suggest that we are still holding a range referrence at this stage
Dim strGet As String: Let strGet = DtaObj.GetText()
Range("A1:B2").Clear ' At this point it is fine to do this
Rem 3 examine string
Call WtchaGot(strIn:=strGet) ' ' Function to see string : https://pastebin.com/gtLaBrf5
'3b Do some modification of the string
Let strGet = Replace(strGet, vbTab, "|", 1, -1, vbBinaryCompare) ' replace in the strGet , vbTab , with "|" pipes , I want all output so starting at first character , -1 means replace all occurances , exact match using computer exact digits
' Call ClearWindowsClipboard ' http://www.excelfox.com/forum/showthread.php/2056-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11020&viewfull=1#post11020 clearing the windows clipboard at this point also messes the simple reverse process from working. This makes no sense at all: Clearly clearing does not always clear things: It may do this in many occasions as one of its actions, but it can also do things which have something near to the opposite effect.
Rem 4 Replace the version previously got using another DataObject method
'4a) Simple reverse action
DtaObj.Clear ' Without this the following 2 line simple reverse action would not work
' DtaObj.SetText Text:=strGet: ' Let strGet = DtaObj.GetText() ' - This always gets the last "addition" ... https://stackoverflow.com/questions/25091571/strange-behavior-from-vba-dataobject-gettext-returns-what-is-currently-on-the-c/54960767#54960767
' DtaObj.PutInClipboard
'4b) Later Late Binding
Dim LaterDtaObj As Object
Set LaterDtaObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
'Set LaterDtaObj = CreateObject("MSForms.DataObject") ' https://bytecomb.com/copy-and-paste-in-vba/
LaterDtaObj.SetText Text:=strGet
LaterDtaObj.PutInClipboard
Rem 5 ' Excel Range Paste ( using Worksheet.Paste method https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.paste )
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
End Sub
Code:
' SHimpfGlified Coding
Sub Early_Copy_and_Later_Late_Binding_Paste()
Rem 1 Late Binding
Dim DtaObj As MSForms.DataObject ' RefMSFORMS.JPG : https://imgur.com/8zKpyr2
Set DtaObj = New MSForms.DataObject
Rem 1 ' Arbritrary Excel range values copy
Let Range("A1").Value = "CellA1": Let Range("A2").Value = "CellA2": Let Range("B1").Value = "CellB1": Let Range("B2").Value = "CellB2"
Rem 2 Clipboard Data object stuff - get the long string that is held in some clipboards
Range("A1:B2").Copy '
DtaObj.GetFromClipboard '
Dim strGet As String: Let strGet = DtaObj.GetText()
Range("A1:B2").Clear
Rem 3 examine string
' Call WtchaGot(strIn:=strGet) '
'3b Do some modification of the string
Let strGet = Replace(strGet, vbTab, "|", 1, -1, vbBinaryCompare)
Rem Simple reverse action. Later Late Binding
Dim LaterDtaObj As Object
Set LaterDtaObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
LaterDtaObj.SetText Text:=strGet
LaterDtaObj.PutInClipboard
Rem 5 ' Excel Range Paste ( using Worksheet.Paste method https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.paste )
ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
End Sub
Sub TestieSimpleArraySort7() ( and Global variables and a required Function )
Global variables should go at top of code module
Code:
Option Explicit
Dim Cms() As Variant, Rs() As Variant ' "HorizointalColumn" Indicies , "Virtical row" Indicies
Dim RngToSort As Range ' Test data range
Dim arrIndx() As Variant ' For modified array at end of each sort of a set of rows
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
Test routine to Call main recursion routine ( given in next post )
Code:
Sub TestieSimpleArraySort7()
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 SimpleArraySort7(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).Clear
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 SimpleArraySort7(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
1 Attachment(s)
Main recursion routine Sub SimpleArraySort7(
Code:
Sub SimpleArraySort7(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
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(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then ' Numeric case
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
Else ' Non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) > UCase(CStr(arsRef(rInner, Clm))) Then
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
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arsRef(rOuter, Clm)) And IsNumeric(arsRef(rInner, Clm)) Then
If CDbl(arsRef(rOuter, Clm)) < CDbl(arsRef(rInner, Clm)) Then
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
Else ' non numeric case
If UCase(CStr(arsRef(rOuter, Clm))) < UCase(CStr(arsRef(rInner, Clm))) Then
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
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
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Clear ' Area for array produced from previous method
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), 0).Value = arsRef()
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Clear ' Area for array produced by Index method idea
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), RngToSort.Columns.Count).Value = arrIndx()
RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Clear
Let RngToSort.Offset((RngToSort.Rows.Count * (CopyNo + 1)), -1).Resize(UBound(Rs(), 1), UBound(Rs(), 2)).Value = Rs() ' Current indicies order to apply to original range
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(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 ' 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 SimpleArraySort7(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
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(arsRef(), 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 SimpleArraySort7(CopyNo + 1, arsRef(), strRws, strKeys)
Else
End If '... ................................................................|
Loop While rOuter <> Rws(UBound(Rws()) - 1) ' keep looking for Duplicates in next row**********|
End Sub
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
