Sorting a Multi-Dimensional Array by Value, Highest to Lowest [Excel, VBA Only]

Hi lloydgodin,

I have approached problems like this by converting all the numbers to strings, all having the same number of digits before and after the decimal point.

You might want to try something like the following:

Option Explicit

Sub QuickAndDirtySortBCA()

  Dim s() As String
  Dim z() As String

  Dim i As Long

  Dim a As Double
  Dim b As Double
  Dim c As Double
  
  Dim sData As String
  
  
  ''''''''''''''''''''''''''
  'Create raw data by converting numbers to strings
  'This simulates reading data from a spreadsheet
  ''''''''''''''''''''''''''
  a = 23410
  b = 7000#
  c = 6939.45

  ReDim s(1 To 1)
  s(1) = Format(b, "00000000.0000000") & " " & Format(c, "00000000.0000000") & " " & Format(a, "00000000.0000000")

  a = 23397
  b = 15000#
  c = 11244.51

  ReDim Preserve s(1 To 2)
  s(2) = Format(b, "00000000.0000000") & " " & Format(c, "00000000.0000000") & " " & Format(a, "00000000.0000000")


  a = 27060
  b = 4000#
  c = 3524.78

  ReDim Preserve s(1 To 3)
  s(3) = Format(b, "00000000.0000000") & " " & Format(c, "00000000.0000000") & " " & Format(a, "00000000.0000000")

  Debug.Print "'''''''''''''''"              'Output in Immediate Window (CTRL G in Debugger)
  Debug.Print "Data Before Sorting:"
  Debug.Print s(1)
  Debug.Print s(2)
  Debug.Print s(3)
  
  ''''''''''''''''''''''''''
  'Sort the strings in the arbitrary order 'b c a'
  ''''''''''''''''''''''''''
  Call LjmBubbleSortStringDescending(s)


  Debug.Print "'''''''''''''''"
  Debug.Print "Data After Sorting:"
  Debug.Print s(1)
  Debug.Print s(2)
  Debug.Print s(3)
  
  
  ''''''''''''''''''''''''''
  'Convert the sorted string back to numberic 'a b c'
  ''''''''''''''''''''''''''
  
  Debug.Print "'''''''''''''''"
  Debug.Print "Data After Decoding the Srings:"
  
  For i = 1 To 3
  
    sData = s(i)
    Call LjmParseString(sData, z)
    
    b = CDbl(z(0))
    c = CDbl(z(1))
    a = CDbl(z(2))
    
    Debug.Print "Line " & i, a, b, c
  
  Next i

  Debug.Print "'''''''''''''''"

End Sub

Sub LjmBubbleSortString(ByRef myArray() As String)
  'This sorts a string array in ascending order using a 'Bubble Sort' algorithm
     
  Dim iFirst As Integer
  Dim iLast As Integer
  Dim i As Integer
  Dim j As Integer
  Dim sTemp As String
     
  'Get the start and end indices
  iFirst = LBound(myArray)
  iLast = UBound(myArray)
    
  'Sort
  For i = iFirst To iLast - 1
    For j = i + 1 To iLast
      If myArray(i) > myArray(j) Then
        sTemp = myArray(j)
        myArray(j) = myArray(i)
        myArray(i) = sTemp
      End If
   Next j
 Next i
     
End Sub

Sub LjmBubbleSortStringDescending(ByRef myArray() As String)
  'This sorts a string array in descending order using a 'Bubble Sort' algorithm
     
  Dim iFirst As Integer
  Dim iLast As Integer
  Dim i As Integer
  Dim j As Integer
  Dim sTemp As String
     
  'Get the start and end indices
  iFirst = LBound(myArray)
  iLast = UBound(myArray)
    
  'Sort
  For i = iFirst To iLast - 1
    For j = i + 1 To iLast
      If myArray(i) < myArray(j) Then
        sTemp = myArray(j)
        myArray(j) = myArray(i)
        myArray(i) = sTemp
      End If
   Next j
 Next i
     
End Sub

Function LjmParseString(InputString As String, ByRef sArray() As String) As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This parses a space delimited string into an array of tokens.
' Leading and trailing spaces are stripped from the string in the process.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  Dim i As Integer
  Dim LastNonEmpty As Integer
  Dim iSplitIndex As Integer

 'Initialization
  LastNonEmpty = -1
  
  'Split the string into tokens
  sArray = Split(InputString)
  iSplitIndex = UBound(sArray)

 'Remove the null tokens
  For i = 0 To iSplitIndex

    If sArray(i) <> "" Then
       'Get rid of all the whitespace
        LastNonEmpty = LastNonEmpty + 1
        sArray(LastNonEmpty) = sArray(i)
    End If
  Next i


 'Return the number of indices
  LjmParseString = LastNonEmpty
  
End Function

Lewis

Lewis,

Sorry for the late reply. I was out of the office yesterday. I took the code you used to sort and was able to get it to work. I was able to do it without converting the numbers. Here is a copy of the working code:

Sub valueSortTest()

    '***SETTING VARIABLES***
    Dim readForm As Worksheet, cpt(1 To 10) As String, charges(1 To 10) As Double, fsValue(1 To 10) As Double
    Dim MaxSort(1 To 3), x As Integer, sortValue(1 To 3, 1 To 10), iFirst As Integer, iLast As Integer
    Dim j As Integer
    
    
    '***IDENTIFYING WORKSHEET TO BE USED***
    Set readForm = ActiveWorkbook.Worksheets("Sheet1")
    iFirst = LBound(charges)
    iLast = UBound(charges)
    
    '***READING DATA INTO AN ARRAY***
    For x = iFirst To iLast
        cpt(x) = readForm.Range("A" & x).Value
        charges(x) = readForm.Range("B" & x).Value
        fsValue(x) = readForm.Range("C" & x).Value
        sortValue(1, x) = cpt(x)
        sortValue(2, x) = charges(x)
        sortValue(3, x) = fsValue(x)
    Next x
    
     '***SORTING ARRRAY [FIRST TIME]***
    
    For x = iFirst To iLast - 1
        For j = x + 1 To iLast
            If sortValue(3, x) < sortValue(3, j) Then
                MaxSort(1) = sortValue(1, j)
                MaxSort(2) = sortValue(2, j)
                MaxSort(3) = sortValue(3, j)
                sortValue(1, j) = sortValue(1, x)
                sortValue(2, j) = sortValue(2, x)
                sortValue(3, j) = sortValue(3, x)
                sortValue(1, x) = MaxSort(1)
                sortValue(2, x) = MaxSort(2)
                sortValue(3, x) = MaxSort(3)
            End If
        Next j
    Next x
             
    '***PLACE SORTED VALUES INTO SPREADSHEET/FORM***
    For x = iFirst To iLast
        readForm.Range("E" & x).Value = sortValue(1, x)
        readForm.Range("F" & x).Value = sortValue(2, x)
        readForm.Range("G" & x).Value = sortValue(3, x)
    Next x

End Sub

Thank you so very much for your help.

You could use something like this.
Note that getting the array from and writing it to a worksheet is just for testing purposes. The array can be gotten any way (as long as it is a 1-based two dimensional array).

The keyColumn and Descending arguments can be adjusted to your liking.
This uses a bubble sort but the "sort row numbers" approach can be used with any kind of sort.
The "build SortedArray using arrRows as a guide" explains the concept behind this.

Sub test()
    Dim unSortedArray As Variant
    Dim SortedArray As Variant
    Dim Descending As Boolean
    Dim arrRows As Variant, rowCount As Long
    Dim keyColumn As Long
    Dim i As Long, j As Long, temp As Long
    
    unSortedArray = Range("A1:C3").Value: Rem get a 2-D array
    
    Descending = True: Rem adjust
    keyColumn = 2: Rem adjust
    
    rowCount = UBound(unSortedArray, 1)
    
    Rem make arrRows = {1, 2, 3, ..., rowCount}
    ReDim arrRows(1 To rowCount)
    For i = 1 To rowCount: arrRows(i) = i: Next i
    
    Rem sort arrRows
    For i = 1 To rowCount - 1
        For j = i + 1 To rowCount
            If (unSortedArray(arrRows(j), keyColumn) < unSortedArray(arrRows(i), keyColumn)) Xor Descending Then
                temp = arrRows(i)
                arrRows(i) = arrRows(j)
                arrRows(j) = temp
            End If
        Next j
    Next i

    Rem build SortedArray using arrRows as a guide
    ReDim SortedArray(1 To rowCount, 1 To UBound(unSortedArray, 2))    
    For i = 1 To rowCount
        For j = 1 To UBound(unSortedArray, 2)
            SortedArray(i, j) = unSortedArray(arrRows(i), j)
        Next j
    Next i
    
    Rem output somewhere (testing)
    Range("E1").Resize(rowCount, UBound(SortedArray, 2)).Value = SortedArray
End Sub