如何僅使用VBA代碼對2D數組中的數字列進行排名

Question

我有一個二維數字數組，5列和5行。 第4列保存第1列至第3列的計算結果，我希望第5列成為第4列的RANK。 我只想在數組中執行此操作，而不要使用工作表。

請注意，我只是為了使工作清楚而使用工作表。

我只想使用代碼，因為它將用於大量計算，並且從工作表寫入/讀取將太慢。

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

程序運行直到到達第二個循環的“ Rank”行，然后給出：

“運行時錯誤1004

“應用程序定義或對象定義的錯誤”

帶注釋的行有效-但這使用了工作表中的數據，這不是我想要的。

那是什么問題呢？ 在這種情況下，為什么排名不起作用？

我正在使用Excel 2007。

Answer 1

范圍期望兩個范圍而不是數組中的項。 但是Rank也不喜歡它需要范圍引用的數組。

首先，我們要第四列的一維數組：

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

這將在第四列之外創建一個一維數組

然后，我們在SUMPRODUCT中使用它

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

我還將輸出更改為工作表一次，以節省一些時間。

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

一注：

如果數組的行數超過45-50，則此方法將不起作用，因為“ Evaluate的字符數限制為255。

Answer 2

如果您不想使用WorksheetFunction.Rank函數，那么編寫自己的排名例程將非常簡單。 一個相當快速的例程如下所示：

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

您會注意到，為簡單起見，我添加了一個名為cValueRankPair的類：

Option Explicit

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

您可以像這樣調用例程：

RankArray arr, 4, 5