Simple Array Bubble Sort Example working similar to VBA Range.Sort with one Key1:=
A further modification is done to the previous routines so that values that can be seen as numbers are compared as numbers in sorting. This is done so that, for example, a number like 46 would be seen as greater than 7. In previous routines, these would be compared as text values of "46" and "7". In a text comparison, the sort is done initially on the first character so that "4" would be seen as less that "7". ( The second character, "6", in this exampple is not used. A second character would only be used to sort if we had two values such as "46" and "49". In such an example VBA would place "49" above "46" for a text comparison
We find that the VBA Range.Sort Method sees text as text and numbers typically as numbers , and the final purpose of the routines we are developing in the associated main forum Thread is to do somethhing similar to the VBA Range.Sort Method
Code:
'
' Simplist Sort3
Sub TestieSimpleArraySort3()
Call SimpleArraySort3(0)
End Sub
'
Sub SimpleArraySort3(Optional ByVal GlLl As Long)
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Dim arrOut() As Variant: Let arrOut() = arrTS() ' could simply use the original array and sort that
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arrTS(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arrOut(), 1)
'If arrOut(rOuter, Clm) > arrOut(rInner, Clm) Then ' This means that I am bigger than the next. So I will swap . I keep doing this which will have the effect of putting the smallest in the current rOuter. By the this and all next rOuter, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next rOuter.
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then ' Numeric case
'If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
'If arrOut(rOuter, Clm) > arrOut(rInner, Clm) Then' If both values are seen to be numeric then this line would probably work, but as "belt and braces" we do the next
If CDbl(arrOut(rOuter, Clm)) > CDbl(arrOut(rInner, Clm)) Then
Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' Non numeric case
'If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
'Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
'Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then
If CDbl(arrOut(rOuter, Clm)) < CDbl(arrOut(rInner, Clm)) Then
'Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
'Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' non numeric case
If UCase(CStr(arrOut(rOuter, Clm))) < UCase(CStr(arrOut(rInner, Clm))) Then
'Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
'Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear ' WsS.Columns("C:D").Clear ' CHANGE TO SUIT
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub
Final comparison results are shown in the next post
First step in turning Bubble Sort routine into function. Routine takes in an Array (ByRef) to sort
Code:
'
Sub TestieSimpleArraySort4()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
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 SimpleArraySort4(arrTS(), 0)
End Sub
Sub SimpleArraySort4(ByRef arrTS() As Variant, Optional ByVal GlLl As Long)
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
' Dim arrTS() As Variant: Let arrTS() = RngToSort.Value ' We would have to use .Value for a range capture of this sort because .Value returns a field of Variant types. But also at this stage we want to preserve string and number types
Dim arrOut() As Variant: Let arrOut() = arrTS() ' could simply use the original array and sort that
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arrTS(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arrOut(), 1)
If GlLl = 0 Then ' We want Ascending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then ' Numeric case
If CDbl(arrOut(rOuter, Clm)) > CDbl(arrOut(rInner, Clm)) Then
Dim temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' Non numeric case
If UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
Else ' GlLl is not 0 , so presumably we want Descending list
If IsNumeric(arrOut(rOuter, Clm)) And IsNumeric(arrOut(rInner, Clm)) Then
If CDbl(arrOut(rOuter, Clm)) < CDbl(arrOut(rInner, Clm)) Then
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Else ' non numeric case
If UCase(CStr(arrOut(rOuter, Clm))) < UCase(CStr(arrOut(rInner, Clm))) Then
For Clms = 1 To UBound(arrOut(), 2)
Let temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
End If ' End of numeric or text comparison
End If ' End of Ascending or Descending example
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
Rem 2 Output for easy of demo
RngToSort.Offset(0, RngToSort.Columns.Count).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count).Value = arrOut()
Let RngToSort.Offset(0, RngToSort.Columns.Count).Interior.Color = vbYellow
End Sub
Initial Function for Simple Bubble Sort
In the routines
Sub TestieSimpleArraySort5() and Function SimpleArraySort5(______) As Variant
below , the main difference over the previous routines is the extra As Variant at the signature line, and finally a code line just before End Function of SimpleArraySort5 = arsRef()
In the testieing routine, we use codes line of this form in the conventional way in which a function is typically used.
_ arrTS() = SimpleArraySort5(arrTS(), _ 0 _ )
But we note that by virtue of using ByRef a simple call would surfice
_Call SimpleArraySort5(arrTS(), _ 0 _ )
Note: we have added an extra testing code section '2b)
In this extra section we fill a new array, arrDesc() , with the sorted array in Descending order. We use for demo purposes a typical function using code line
_ arrDesc() = SimpleArraySort5(arrTS(), 2136)
Correspondingly we have a demo output giving code line
_ RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrDesc()
We note further, that this is somewhat redundant. This is because the code part SimpleArraySort5(arrTS(), 2136) has the effect of re filling arrTS() with the newly sorted array by virtue of the use of ByRef in the signature line of the Function
We could therefore simply use a code line like _..
_Call SimpleArraySort5(arrTS(), 357)
_.. followed by an demo output giving line of
_ RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrTS()
Code:
Sub TestieSimpleArraySort5()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As Range: Set RngToSort = WsS.Range("A2:B9")
' 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 SimpleArraySort5(arrTS(), 0)
Let arrTS() = SimpleArraySort5(arrTS(), 0)
Rem 2 Output for easy of demo
' 2a) Ascending
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) Descending ( using diiffernet variable )
Dim arrDesc() As Variant
Let arrDesc() = SimpleArraySort5(arrTS(), 2136)
RngToSort.Offset(0, RngToSort.Columns.Count * 3).Clear
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrDesc()
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Value = arrTS() ' Because we use ByRef this would work after any normal Call of SimpleArraySort5(arrTS(), ) The actual call we use puts the sorted array in arrTS() The important bit is SimpleArraySort5(arrTS(), ) After this arrTS() with the newly sorted array by virtue of the use of ByRe in the signature line of this Function has the effect of refilling arrTS() with the newly sorted in descending order values
Let RngToSort.Offset(0, RngToSort.Columns.Count * 3).Interior.Color = vbYellow
End Sub
Function SimpleArraySort5(ByRef arsRef() As Variant, Optional ByVal GlLl As Long) As Variant
' column to be used for determining order of rows sorted array: the values in this column will be looked at
Dim Clm As Long: Let Clm = 1
Rem 1 Simple Bubble Sort
Dim rOuter As Long ' ========"Left Hand"=====================Outer Loop=====================================
For rOuter = 1 To UBound(arsRef(), 1) - 1 ' For row 1 to the (last row -1) last row, given by the first dimension upper limit of the array
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(arsRef(), 1)
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 ' ===========================================================================================
Let SimpleArraySort5 = arsRef()
End Function
In the next post are some typical test results for the above coding
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
