sorting an array

[johnboy12]

Dear all,

Does anyone know a fast way to sort the rows of a 2-dim array (in descending order) by a particular column. For example, suppose I've got the following array

V W X Y Z (the column names)
----------------------------------
a1 a2 a3 a4 a5
b1 b2 b3 b4 b5
c1 c2 c3 c4 c5
d1 d2 d3 d4 d5

I want to sort this array by variable Y. Let's suppose c4>a4>d4>b4
Thus, I want back

c1 c2 c3 c4 c5
a1 a2 a3 a4 a5
d1 d2 d3 d4 d5
b1 b2 b3 b4 b5

I have a big 2-d array, so something fast would be really helpful. Can anyone help with this problem?

Thanks in advance.

Regards,
John

[shg]

Like this:

    Range("W1:Z4").Sort Key1:=Range("Y1"), Order1:=xlDescending, _
                        Header:=xlNo, Orientation:=xlSortColumns

See VBA Help for the Sort method

[johnboy12]

Thanks. But the data isn't contained in the worksheet. It is manipulated and created in VBA itself. Was looking for a sub-routine to do this.

[mikerickson]

The UDF in this thread
http://www.excelforum.com/showthread.php?t=649634
will accept either a range or an array as its first argument.

(Since posting that, I've developed a more generalized version, let me know if you want me to post that.)

[shg]

mikerickson, that's a self-referential link ...

[mikerickson]

Thanks Shg,

Oops,
Now that I'm at my home computer, I'll post the current best version.

Option Explicit
Public imageArray As Variant
Public keyCol As Long, keyCol2

Function QSortedArray(ByVal inputRange As Variant, Optional keyColumn As Long, Optional keyColumn2 As Long, Optional Descending As Boolean) As Variant
    Dim RowArray As Variant
    Dim outRRay As Variant
    Dim i As Long, j As Long, size As Long
     
    If keyColumn = 0 Then keyColumn = 1
     
    Rem Input array vs range handeling
    On Error GoTo HaltFunction
    Select Case TypeName(inputRange)
    Case Is = "Range"
        If inputRange.Columns.Count < keyColumn Then
            QSortedArray = CVErr(xlErrRef): Exit Function
        Else
            Set inputRange = Application.Intersect(inputRange, inputRange.Parent.UsedRange)
            If inputRange Is Nothing Then
                QSortedArray = Array(vbNullString): Exit Function
            Else
                imageArray = inputRange.Value
            End If
        End If
         
    Case Is = "Variant()", "String()", "Double()", "Long()"
        If UBound(inputRange, 2) < keyColumn Then
            QSortedArray = Array(CVErr(xlErrRef)): Exit Function
        Else
            imageArray = inputRange
        End If
         
    Case Else
        QSortedArray = CVErr(xlErrNA): Exit Function
    End Select
    On Error GoTo 0
     
    Rem pass arguments To Public variables
    
    If keyColumn2 = 0 Then keyColumn2 = keyColumn
    If UBound(imageArray, 2) < keyColumn Then QSortedArray = CVErr(xlErrRef): Exit Function
    If UBound(imageArray, 2) < keyColumn2 Then QSortedArray = CVErr(xlErrRef): Exit Function
    keyCol = keyColumn
    keyCol2 = keyColumn2
    
    Rem create array of row numbers {1,2,3,...,Rows.Count}
    size = UBound(imageArray, 1)
    ReDim RowArray(1 To size)
    For i = 1 To size
        RowArray(i) = i
    Next i
     
    Rem sort row numbers
    Call sortQuickly(RowArray, Descending)
     
    Rem read imageArray With row order per the sorted RowArray
    ReDim outRRay(1 To size, 1 To UBound(imageArray, 2))
    For i = 1 To size
        For j = 1 To UBound(outRRay, 2)
            outRRay(i, j) = imageArray(RowArray(i), j)
        Next j
    Next i
     
    QSortedArray = outRRay
     
    Erase imageArray
HaltFunction:
    On Error GoTo 0
End Function
 
Sub sortQuickly(ByRef inRRay As Variant, Optional ByVal Descending As Boolean, Optional ByVal low As Long, Optional ByVal high As Long)
    Dim pivot As Variant
    Dim i As Long, pointer As Long
    If low = 0 Then low = LBound(inRRay)
    If high = 0 Then high = UBound(inRRay)
     
    pointer = low
     
    Call Swap(inRRay, (low + high) / 2, high)
    pivot = inRRay(high)
     
    For i = low To high - 1
        If LT(inRRay(i), pivot) Xor Descending Then
            Call Swap(inRRay, i, pointer)
            pointer = pointer + 1
        End If
    Next i
    Call Swap(inRRay, pointer, high)
    If low < pointer - 1 Then
        Call sortQuickly(inRRay, Descending, low, pointer - 1)
    End If
    If pointer + 1 <= high Then
        Call sortQuickly(inRRay, Descending, pointer + 1, high)
    End If
End Sub
 
Function LT(aRow As Variant, bRow As Variant, Optional Descending As Boolean) As Boolean
    On Error GoTo HaltFtn
    LT = Descending
    If imageArray(aRow, keyCol) = imageArray(bRow, keyCol) Then
        LT = imageArray(aRow, keyCol2) < imageArray(bRow, keyCol2)
    Else
        LT = (imageArray(aRow, keyCol) < imageArray(bRow, keyCol))
    End If
HaltFtn:
    On Error GoTo 0
End Function
 
Sub Swap(ByRef inRRay, a As Long, b As Long)
    Dim temp As Variant
    temp = inRRay(a)
    inRRay(a) = inRRay(b)
    inRRay(b) = temp
End Sub

QSortedArray can either be entered as an array formula on a spreadsheet, or used in a VB routine to return a sorted array.

[jindon]

try

Sub test()
Dim a(), i As Long, myOrder, x
a = [{"a1","a2","a3","a4","a5";"b1","b2","b3","b4","b5"; _
        "c1","c2","c3","c4,"c5";"d1""d2","d3","d4","d5"}]
myOrder = Array("c4","a4","d4","b4")
With Application.WorksheetFunction
    For i = 1 To UBound(a,1)
        msg = msg & vbLf & Join(.Transpose(.Transpose(.Index(a, i, 0))), ",")
    Next
End With
MsgBox "Before sort" & msg : msg = ""
ReDim Preserve a(1 To UBound(a,1), 1 To UBound(a,2) + 1)
For i = 1 To UBound(a,1)
    x = Application.Match(a(i,4), myOrder, 0)
    If IsErro(x) Then x = a(i,4)
    a(i, UBound(a,2)) = x
Next
VSortMA a, 1, UBound(a,1), UBound(a,2)
ReDim Preserve a(1 To UBound(a,1), 1 To UBound(a,2) - 1)
With Application.WorksheetFunction
    For i = 1 To UBound(a,1)
        msg = msg & vbLf & Join(.Transpose(.Transpose(.Index(a, i, 0))), ",")
    Next
End With
MsgBox "After sort" & msg
End Sub

Private Sub VSortMA(ary, LB, UB, ref) 
Dim M As Variant, i As Long, ii As Long, iii As Long
i = UB : ii = LB 
M = ary(Int((LB+UB)/2),ref) 
Do While ii <= i 
     Do While ary(ii,ref) < M 
          ii = ii + 1 
     Loop 
     Do While ary(i,ref) > M 
          i = i - 1 
     Loop 
     If ii <= i Then 
          For iii = LBound(ary,2) To UBound(ary,2) 
               temp = ary(ii,iii) : ary(ii,iii) = ary(i,iii) : ary(i,iii) = temp 
          Next 
          ii = ii + 1 : i = i - 1 
     End If 
Loop 
If LB < i Then VSortMA ary, LB, i, ref 
If ii < UB Then VSortMA ary, ii, UB, ref 
End Sub