Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)

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

Worksheet: Sorting

_Row\^Col	A	B	C	D	E	F
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

Further Examples using the routines from the previous post
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()

_____ ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

1

2
c WasB2
32
WasB8
6
WasB7

3
AB WasB3
6
WasB7
32
WasB8

4
Aa WasB4 A WasB5 A WasB5

5
A WasB5 Aa WasB4 Aa WasB4

6
C WasB6 AB WasB3 AB WasB3

7

6
WasB7 bcde WasB9 bcde WasB9

8

32
WasB8 C WasB6 c WasB2

9
bcde WasB9 c WasB2 C WasB6

10

Worksheet: Sorting

To reverse this to descending so that things “get smaller as you go down the rows”, you simply need to change
the > to a < in the array routine
and
the Order1:=xlAscending to Order1:=xlDescending in the VBA Range.Sort routine
_____ ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

1

2
c WasB2 c WasB2 c WasB2

3
AB WasB3 C WasB6 C WasB6

4
Aa WasB4 bcde WasB9 bcde WasB9

5
A WasB5 AB WasB3 AB WasB3

6
C WasB6 Aa WasB4 Aa WasB4

7

6
WasB7 A WasB5 A WasB5

8

32
WasB8
6
WasB7
32
WasB8

9
bcde WasB9
32
WasB8
6
WasB7

10

Worksheet: Sorting

I intended developing the solution into a function, so as a start to this, the routine will be modified to take an Optional argument of 0 or 1 , with the default of 0 being the case for an Ascending list. I am not being particularly efficient with the coding, and will duplicate sections.

A full routine is posted in the next post

_Row\^Col	A	B	C	D	E	F
1
2	c	WasB2	32	WasB8	6	WasB7
3	AB	WasB3	6	WasB7	32	WasB8
4	Aa	WasB4	A	WasB5	A	WasB5
5	A	WasB5	Aa	WasB4	Aa	WasB4
6	C	WasB6	AB	WasB3	AB	WasB3
7	6	WasB7	bcde	WasB9	bcde	WasB9
8	32	WasB8	C	WasB6	c	WasB2
9	bcde	WasB9	c	WasB2	C	WasB6
10

_Row\^Col	A	B	C	D	E	F
1
2	c	WasB2	c	WasB2	c	WasB2
3	AB	WasB3	C	WasB6	C	WasB6
4	Aa	WasB4	bcde	WasB9	bcde	WasB9
5	A	WasB5	AB	WasB3	AB	WasB3
6	C	WasB6	Aa	WasB4	Aa	WasB4
7	6	WasB7	A	WasB5	A	WasB5
8	32	WasB8	6	WasB7	32	WasB8
9	bcde	WasB9	32	WasB8	6	WasB7
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

Worksheet: Sorting

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

Worksheet: Sorting

_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

_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

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 SimpleArraySort3() , and the green highlighted range is that produced by the VBA Range.Sort method routine, Sub Range_Sort()

Ascending Order

Code:

Sub TestieSimpleArraySort3() Call SimpleArraySort3(0) End Sub '

Code:

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 'RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlDescending, MatchCase:=False Let RngCopy.Interior.Color = vbGreen End Sub

_____ ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

1

2
c WasB2
6
WasB7
6
WasB7

3
AB WasB3
32
WasB8
32
WasB8

4
Aa WasB4 A WasB5 A WasB5

5
A WasB5 Aa WasB4 Aa WasB4

6
C WasB6 AB WasB3 AB WasB3

7

6
WasB7 bcde WasB9 bcde WasB9

8

32
WasB8 C WasB6 c WasB2

9
bcde WasB9 c WasB2 C WasB6

10

Worksheet: Sorting

Descending Order

Code:

Sub TestieSimpleArraySort3() Call SimpleArraySort3(2246) End Sub '

Code:

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 RngCopy.Sort Key1:=RngCopy.Columns("A:A"), Order1:=xlDescending, MatchCase:=False Let RngCopy.Interior.Color = vbGreen End Sub

_____ ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

1

2
c WasB2 c WasB2 c WasB2

3
AB WasB3 C WasB6 C WasB6

4
Aa WasB4 bcde WasB9 bcde WasB9

5
A WasB5 AB WasB3 AB WasB3

6
C WasB6 Aa WasB4 Aa WasB4

7

6
WasB7 A WasB5 A WasB5

8

32
WasB8
32
WasB8
32
WasB8

9
bcde WasB9
6
WasB7
6
WasB7

10

Worksheet: Sorting

_Row\^Col	A	B	C	D	E	F
1
2	c	WasB2	6	WasB7	6	WasB7
3	AB	WasB3	32	WasB8	32	WasB8
4	Aa	WasB4	A	WasB5	A	WasB5
5	A	WasB5	Aa	WasB4	Aa	WasB4
6	C	WasB6	AB	WasB3	AB	WasB3
7	6	WasB7	bcde	WasB9	bcde	WasB9
8	32	WasB8	C	WasB6	c	WasB2
9	bcde	WasB9	c	WasB2	C	WasB6
10

_Row\^Col	A	B	C	D	E	F
1
2	c	WasB2	c	WasB2	c	WasB2
3	AB	WasB3	C	WasB6	C	WasB6
4	Aa	WasB4	bcde	WasB9	bcde	WasB9
5	A	WasB5	AB	WasB3	AB	WasB3
6	C	WasB6	Aa	WasB4	Aa	WasB4
7	6	WasB7	A	WasB5	A	WasB5
8	32	WasB8	32	WasB8	32	WasB8
9	bcde	WasB9	6	WasB7	6	WasB7
10

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

Because we are using ByRef , the previous testieing Calling routine can also use the original supplied array, arrTS() , after the main procedure Call , provided that the array taken in at the signature line is that sorted, as that will in effect be the same array and it will reflect the changes done to it.

Pseudo code ByRef ‘ ( Usually default option )
varMyArray = x
_ Call ReferToIt(varMyArray)
Sub ReferToIt(ByRef arr)
_ arr=y ‘ This is similar to saying varMyArray = y
End
varMyArray is now = y ‘ because effectively varMyArray was in arr

Code:

' Sub TestieSimpleArraySort4b() 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 SimpleArraySort4b(arrTS(), 0) Rem 2 Output for easy of demo 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 End Sub Sub SimpleArraySort4b(ByRef arsRef() As Variant, Optional ByVal GlLl As Long) ' 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 ' =========================================================================================== 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

Some typical resullts using the coding from the last post

Consider this test input range

_____ ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

1

2
c WasB2

3
AB WasB3

4
Aa WasB4

5
A WasB5

6
C WasB6

7

6
WasB7

8

32
WasB8

9
bcde WasB9

10

Worksheet: Sorting

After running Sub TestieSimpleArraySort5() , you should see this:

_____ ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

H

I

1

2
c WasB2
6
WasB7 C WasB6

3
AB WasB3
32
WasB8 c WasB2

4
Aa WasB4 A WasB5 bcde WasB9

5
A WasB5 Aa WasB4 AB WasB3

6
C WasB6 AB WasB3 Aa WasB4

7

6
WasB7 bcde WasB9 A WasB5

8

32
WasB8 C WasB6
32
WasB8

9
bcde WasB9 c WasB2
6
WasB7

10

Worksheet: Sorting

_Row\^Col	A	B
1
2	c	WasB2
3	AB	WasB3
4	Aa	WasB4
5	A	WasB5
6	C	WasB6
7	6	WasB7
8	32	WasB8
9	bcde	WasB9
10

_Row\^Col	A	B	C	D	G	H
1
2	c	WasB2	6	WasB7	C	WasB6
3	AB	WasB3	32	WasB8	c	WasB2
4	Aa	WasB4	A	WasB5	bcde	WasB9
5	A	WasB5	Aa	WasB4	AB	WasB3
6	C	WasB6	AB	WasB3	Aa	WasB4
7	6	WasB7	bcde	WasB9	A	WasB5
8	32	WasB8	C	WasB6	32	WasB8
9	bcde	WasB9	c	WasB2	6	WasB7
10

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

Worksheet: Sorting

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

_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