How can I Rank a Column of Numbers in a 2D array using only vba code

Question

I have a 2D array of numbers, 5 columns and 5 rows. The 4th column holds the result of calculations on cols 1 to 3 and I want the 5th column to be the RANK of the 4th column. I want to do this in the array only and not use the sheet.

Notice I'm only using the sheet for clarity of working whilst getting it to work.

I want to use only code because it will be working with a large number of calculations, and writing /reading from sheet will be too slow.

Sub RankArray()

Dim arr()
ReDim arr(1 To 5, 1 To 5)

For y = 1 To 5
    For x = 1 To 3
        arr(y, x) = Int((99 * Rnd) + 1)
        Sheet1.Cells(y, x) = arr(y, x)
    Next x
    arr(y, 4) = arr(y, 1) + arr(y, 2) + arr(y, 3)
    Sheet1.Cells(y, 4) = arr(y, 4)
Next y

For y = 1 To 5
    'arr(y, 5) = WorksheetFunction.Rank(arr(y, 4), Range("D1:D5"))    
    arr(y, 5) = WorksheetFunction.Rank(arr(y, 4), Range(arr(1, 4), arr(5, 4)))
    Sheet1.Cells(y, 5) = arr(y, 5)
Next y

End Sub

The program runs until it gets to the 'Rank' line in the second loop - which then gives:-

"Runtime error 1004

"Application-defined or object-defined error"

The commented out line works - but this uses data from the sheet which is not what I want.

So what is the problem? Why won't Rank work in this case?

I'm using Excel 2007.

Answer 1

Range expects two ranges not items in an array. But also Rank does not like arrays it wants a range reference.

First we want a one dimensional array of the 4th column:

    Dim t As Variant
    t = Application.Transpose(Application.Index(arr, 0, 4))

this will create a one dimensional array out of the 4th column

We then use that in SUMPRODUCT

arr(y, 5) = Application.Evaluate("SumProduct(--({" & Join(t, ",") & "} <= " & arr(y, 4) & "))")

I also changed the output to just once to the worksheet to save some time.

Sub RankArray()

    Dim arr()
    ReDim arr(1 To 5, 1 To 5)

    Dim y As Long
    For y = 1 To 5
        Dim x As Long
        For x = 1 To 3
            arr(y, x) = Int((99 * Rnd) + 1)
        Next x
        arr(y, 4) = arr(y, 1) + arr(y, 2) + arr(y, 3)
    Next y

    Dim t As Variant
    t = Application.Transpose(Application.Index(arr, 0, 4))

    For y = 1 To 5
        arr(y, 5) = Application.Evaluate("SumProduct(--({" & Join(t, ",") & "} <= " & arr(y, 4) & "))")
    Next y

    Sheet1.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

End Sub

One note:

This will not work if the array has more than 45-50 rows as Evaluate has a 255 character limit.

Answer 2

If you didn't want to use the WorksheetFunction.Rank function, it would be fairly simple to write your own ranking routine. A reasonably fast routine would look something like below:

Private Sub RankArray(ByRef rArr() As Variant, refIndex As Long, rankIndex As Long)
    Dim i As Long
    Dim uniques As Collection
    Dim vrp As cValueRankPair, unique As cValueRankPair


    Set uniques = New Collection
    For i = LBound(rArr, 1) To UBound(rArr, 1)
        'Check if value already exists.
        Set vrp = Nothing: On Error Resume Next
        Set vrp = uniques(CStr(rArr(i, refIndex))): On Error GoTo 0

        If vrp Is Nothing Then

            'It's a new value, so add it in ascending order.
            For Each unique In uniques
                If rArr(i, refIndex) < unique.Value Then
                    Set vrp = New cValueRankPair
                    vrp.Value = rArr(i, refIndex)
                    uniques.Add vrp, CStr(vrp.Value), Before:=CStr(unique.Value)
                    Exit For
                End If
            Next

            'If it wasn't already added, then add it as last item.
            If vrp Is Nothing Then
                Set vrp = New cValueRankPair
                vrp.Value = rArr(i, refIndex)
                uniques.Add vrp, CStr(vrp.Value)
            End If
        End If

        'Increment the count for this value.
        vrp.Count = vrp.Count + 1
    Next

    'Set the rank values.
    i = 1
    For Each unique In uniques
        unique.Rank = i
        i = i + unique.Count
    Next

    'Populate the array.
    For i = LBound(rArr, 1) To UBound(rArr, 1)
        'We don't really need this check.
        Set vrp = Nothing: On Error Resume Next
        Set vrp = uniques(CStr(rArr(i, refIndex))): On Error GoTo 0

        'Write the rank to array.
        If Not vrp Is Nothing Then
            rArr(i, rankIndex) = vrp.Rank
        End If
    Next
End Sub

You'll note that for simplicity I've added a class called cValueRankPair :

Option Explicit

Public Value As Variant
Public Rank As Long
Public Count As Long

You'd just call the routine like so:

RankArray arr, 4, 5