Excel 如何仅使用vba代码对二维数组中的数字列进行排序

我有一个2D数字数组，5列5行。第4列保存cols 1到3的计算结果，我希望第5列是第4列的秩。我只想在数组中执行此操作，而不使用工作表

请注意，我只是为了工作的清晰性而使用该表，同时让它工作

我只想使用代码，因为它将处理大量计算，并且从工作表中写入/读取的速度太慢

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

程序运行直到到达第二个循环中的“秩”行，然后给出：-

“运行时错误1004

“应用程序定义或对象定义错误”

注释掉的行是有效的，但是它使用的数据不是我想要的

那么问题是什么呢？为什么在这种情况下不进行排名

---

我正在使用Excel 2007。

Range需要两个范围，而不是数组中的项。但是Rank也不喜欢数组，它需要范围引用

首先，我们需要第4列的一维数组：

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

这将从第4列创建一个一维数组

然后我们在SUMPRODUCT中使用它

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

---

arr（y，5）=Application.Evaluate（“SumProduct”（{“&Join（t）”，”）&“}如果您不想使用
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

你可以这样称呼例行程序：

RankArray arr, 4, 5

请注意，您提供的是
Range
两个参数；第一个参数是
arr（1，4）
所具有的值，第二个参数是
arr（5，4）
所具有的值。这根本不等同于
Range（“D1:D5”）
数组。您的意思是给它一个
arr
数组的切片，但您并不是在切片它：）这个解决方案非常有效，我唯一更改的是将“Application.Evaluate”行更改为：-'arr（y，5）=**（Uy+1）-**Application.Evaluate（“SumProduct”（{“&Join（t）”，”）&“}），从而使其将最高值列为1
Option Explicit

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

RankArray arr, 4, 5