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

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

Questions:

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.

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.

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)
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)
Exit For
End If
Next

If vrp Is Nothing Then
Set vrp = New cValueRankPair
vrp.Value = rArr(i, refIndex)
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
``````