Simple Array Bubble Sort Example with Range.Sort Equivalent
Coding in support of this excelfox Thread:
llkslksjjsjfaslkjflkajflkjflfjj later sajfsladj
Code:
Option Explicit
'
' Range.Sort Example
Sub RangeSortExample()
range("G13:K19").Sort Key1:=range("G13:K19").Columns("B:B"), Order1:=xlAscending, Key2:=range("G13:K19").Columns("D:D"), order2:=xlAscending, MatchCase:=False, Key3:=range("G13:K19").Columns("E:E"), order3:=xlDescending, MatchCase:=False
End Sub ' Matchcase:=False '
' Simplist Sort
Sub SimpleArraySort()
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 UCase(CStr(arrOut(rOuter, Clm))) > UCase(CStr(arrOut(rInner, Clm))) Then
Dim Temp As Variant ' I want to Swap those 2 above - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Dim Clms As Long '-------| with the condition met a loop is done for all columns in the array in which those two values used in the comparison are replaced at each column
For Clms = 1 To UBound(arrOut(), 2)
Let Temp = arrOut(rOuter, Clms): Let arrOut(rOuter, Clms) = arrOut(rInner, Clms): Let arrOut(rInner, Clms) = Temp
Next Clms '----------| for each column in the array at the two rows rOuter and rInner
Else
End If
Next rInner ' ---------------------------------------------------------------------
Next rOuter ' ===========================================================================================
Rem 2 Output for easy of demo
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
' Approximate equivalent to the above routune, using VBA Range.Sort Method ' https://docs.microsoft.com/de-de/office/vba/api/excel.range.sort
Sub Range_Sort()
Rem 0 test data, worksheets info
Dim WsS As Worksheet: Set WsS = ThisWorkbook.Worksheets("Sorting")
Dim RngToSort As range: Set RngToSort = WsS.range("A2:B9")
' alternative:
' Set RngToSort = Selection ' ' Selection.JPG : https://imgur.com/HnCdBt8
Rem 1 For demo purposes we will sort a copy of the range
RngToSort.Offset(0, RngToSort.Columns.Count * 2).Clear ' WsS.Columns("E:F").Clear ' CHANGE TO SUIT
RngToSort.Copy Destination:=RngToSort.Offset(0, RngToSort.Columns.Count * 2)
Dim RngCopy As range: Set RngCopy = RngToSort.Offset(0, RngToSort.Columns.Count * 2)
RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlAscending, MatchCase:=False
'
Let RngCopy.Interior.Color = vbGreen
End Sub
Typical results:
The sorted array is displayed in the spreadsheet along side the original range used as test data for the inputted array. ( The yellow highlighted range is that produced by the array sort routine, Sub SimpleArraySort() , and the green highlighted range is that produced by the VBA Range.Sort method routine, Sub Range_Sort()
More examples in next post.
_____ ( Using Excel 2007 32 bit )
| Row\Col |
A |
B |
C |
D |
E |
F |
G |
|---|
1 |
|
|
|
|
|
|
|
2 |
c |
WasB2 |
A |
WasB5 |
A |
WasB5 |
|
3 |
AB |
WasB3 |
Aa |
WasB4 |
Aa |
WasB4 |
|
4 |
Aa |
WasB4 |
AB |
WasB3 |
AB |
WasB3 |
|
5 |
A |
WasB5 |
B |
WasB7 |
B |
WasB7 |
|
6 |
C |
WasB6 |
b |
WasB8 |
b |
WasB8 |
|
7 |
B |
WasB7 |
bcde |
WasB9 |
bcde |
WasB9 |
|
8 |
b |
WasB8 |
C |
WasB6 |
c |
WasB2 |
|
9 |
bcde |
WasB9 |
c |
WasB2 |
C |
WasB6 |
|
10 |
|
|
|
|
|
|
|
Simpla Array Bubble Sort Program allowing for Ascending or Descending order
The last routine, Sub TestieSimpleArraySort(), has a section dupilcated to allow for selection of a final list sorted in Ascending or descending order.
If supplied 0, or , no GlLl argument is given, then the final list should be sorted in Ascending order
Code:
' Simplist Sort2
Sub TestieSimpleArraySort2()
Call SimpleArraySort2(0)
End Sub
'
Sub SimpleArraySort2(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 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
Else ' GlLl is not 0 , so presumably we want Descending list
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 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
Results for this callind procedure
Code:
Sub TestieSimpleArraySort2()
Call SimpleArraySort2(0)
Call SimpleArraySort
End Sub
'
_____ ( Using Excel 2007 32 bit )
| Row\Col |
A |
B |
C |
D |
|---|
2 |
c |
WasB2 |
32 |
WasB8 |
3 |
AB |
WasB3 |
6 |
WasB7 |
4 |
Aa |
WasB4 |
A |
WasB5 |
5 |
A |
WasB5 |
Aa |
WasB4 |
6 |
C |
WasB6 |
AB |
WasB3 |
7 |
6 |
WasB7 |
bcde |
WasB9 |
8 |
32 |
WasB8 |
C |
WasB6 |
9 |
bcde |
WasB9 |
c |
WasB2 |
Results for this calling procedure
Code:
Sub TestieSimpleArraySort2()
Call SimpleArraySort2(732847)
End Sub
'
_____ ( Using Excel 2007 32 bit )
| Row\Col |
A |
B |
C |
D |
|---|
2 |
c |
WasB2 |
c |
WasB2 |
3 |
AB |
WasB3 |
C |
WasB6 |
4 |
Aa |
WasB4 |
bcde |
WasB9 |
5 |
A |
WasB5 |
AB |
WasB3 |
6 |
C |
WasB6 |
Aa |
WasB4 |
7 |
6 |
WasB7 |
A |
WasB5 |
8 |
32 |
WasB8 |
6 |
WasB7 |
9 |
bcde |
WasB9 |
32 |
WasB8 |
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
