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
Bookmarks