RANK.AVG Excel функция внутри MS Access

Question

Я пытаюсь использовать функцию Excel RANK.AVG в своем коде MS ACCESS VBA, но она дает мне ошибку во время выполнения «1004».

Вот мой код:

Dim oExcel As Object
Set oExcel = CreateObject("excel.application")

For i = 0 To RowCount - 1
Arrfld4(i) = oExcel.Worksheetfunction.RANK.AVG(Arrfld1(i), Arrfld1())
Next i

Debug.Print vbNewLine

For i = 0 To RowCount - 1
    Debug.Print Arrfld4(i)
Next i

в Arrfld1 () - это те значения:

 7 
 7 
 6 
 5 
 4 
 4 
 4 
 3 
 3 
 3 
 2 
 1 
 1 

И мой ожидаемый результат в Arrfld4 ():

 1,5 
 1,5 
 3 
 4 
 6 
 6 
 6 
 9 
 9 
 9 
 11 
 12,5 
 12,5

Answer 1

Вы можете реализовать ранжирование для массива самостоятельно, хотя VBA предлагает мало инструментов для работы с массивами, поэтому для этого потребуется немало вспомогательных функций. Фактическая логика c для ранжирования является не сложной, поэтому ее легко реализовать.

Основная функция:

Public Function Array_Rank(vArray As Variant, Optional SortArray = False) As Double()
    Dim vOut() As Double
    ReDim vOut(LBound(vArray) To UBound(vArray))
    If SortArray Then Array_Bubblesort vArray
    Dim l As Long
    Dim t As Variant
    For l = LBound(vArray) To UBound(vArray)
        t = Array_Positions(vArray(l), vArray)
        Array_Increment 1 - LBound(vArray), t
        vOut(l) = Array_Avg(t)
    Next
    Array_Rank = vOut
End Function

Вспомогательные функции:

Public Function Array_Positions(vKey As Variant, vArray As Variant) As Long()
    Dim out() As Long
    Dim l As Long
    Dim pos As Long
    For l = LBound(vArray) To UBound(vArray)
        If vArray(l) = vKey Then
            ReDim Preserve out(pos)
            out(pos) = l
            pos = pos + 1
        End If
    Next
    Array_Positions = out
End Function

Public Sub Array_Increment(vOffset As Variant, ByRef vArray As Variant)
    Dim l As Long
    For l = LBound(vArray) To UBound(vArray)
        vArray(l) = vArray(l) + vOffset
    Next
End Sub

Public Function Array_Sum(vArray As Variant) As Variant
    Dim l As Long
    For l = LBound(vArray) To UBound(vArray)
        Array_Sum = Array_Sum + vArray(l)
    Next
End Function

Public Function Array_Count(vArray As Variant) As Long
    On Error Resume Next 'Will error on uninitialized arrays, return 0 in that case
    Array_Count = UBound(vArray) - LBound(vArray) + 1
End Function

Public Function Array_Avg(vArray As Variant) As Variant
    Array_Avg = Array_Sum(vArray) / Array_Count(vArray)
End Function

Public Sub Array_Bubblesort(ByRef vArray As Variant)
    Dim l As Long
    Dim iter As Long
    iter = 1
    Dim hasSwapped As Boolean
    hasSwapped = True
    Dim t As Variant
    Do While hasSwapped And iter <= UBound(vArray) - LBound(vArray)
        hasSwapped = False
        For l = LBound(vArray) To UBound(vArray) - iter
            If vArray(l) > vArray(l + 1) Then
                t = vArray(l)
                vArray(l) = vArray(l + 1)
                vArray(l + 1) = t
                hasSwapped = True
            End If
        Next
        iter = iter + 1
    Loop
End Sub

Реализация в виде просто, как:

Arrfld4 = Array_Rank(Arrfld1)

И у вас есть нужный массив.

Обратите внимание, что это не сделано для оптимальной работы (в основном Array_Positions может быть переписан, чтобы не требовать Redim Preserve), но это будет быстрее, чем большинство других решений, если у вас есть массив в памяти.

Answer 2

Вам не нужен Excel для этого. Это можно сделать в Access, используя collection :

' Returns, by the value of a field, the rank of one or more records of a table or query.
' Supports all five common ranking strategies (methods).
'
' Source:
'   WikiPedia: https://en.wikipedia.org/wiki/Ranking
'
' Supports ranking of descending as well as ascending values.
' Any ranking will require one table scan only.
' For strategy Ordinal, a a second field with a subvalue must be used.
'
' Typical usage (table Products of Northwind sample database):
'
'   SELECT Products.*, RowRank("[Standard Cost]","[Products]",[Standard Cost]) AS Rank
'   FROM Products
'   ORDER BY Products.[Standard Cost] DESC;
'
' Typical usage for strategy Ordinal with a second field ([Product Code]) holding the subvalues:
'
'   SELECT Products.*, RowRank("[Standard Cost],[Product Code]","[Products]",[Standard Cost],[Product Code],2) AS Ordinal
'   FROM Products
'   ORDER BY Products.[Standard Cost] DESC;
'
' To obtain a rank, the first three parameters must be passed.
' Four parameters is required for strategy Ordinal to be returned properly.
' The remaining parameters are optional.
'
' The ranking will be cached until Order is changed or RowRank is called to clear the cache.
' To clear the cache, call RowRank with no parameters:
'
'   RowRank
'
' Parameters:
'
'   Expression: One field name for other strategies than Ordinal, two field names for this.
'   Domain:     Table or query name.
'   Value:      The values to rank.
'   SubValue:   The subvalues to rank when using strategy Ordinal.
'   Strategy:   Strategy for the ranking.
'   Order:      The order by which to rank the values (and subvalues).
'
' 2019-07-11. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function RowRank( _
    Optional ByVal Expression As String, _
    Optional ByVal Domain As String, _
    Optional ByVal Value As Variant, _
    Optional ByVal SubValue As Variant, _
    Optional ByVal Strategy As ApRankingStrategy = ApRankingStrategy.apStandardCompetition, _
    Optional ByVal Order As ApRankingOrder = ApRankingOrder.apDescending) _
    As Double

    Const SqlMask1          As String = "Select Top 1 {0} From {1}"
    Const SqlMask           As String = "Select {0} From {1} Order By 1 {2}"
    Const SqlOrder          As String = ",{0} {1}"
    Const OrderAsc          As String = "Asc"
    Const OrderDesc         As String = "Desc"
    Const FirstStrategy     As Integer = ApRankingStrategy.apDense
    Const LastStrategy      As Integer = ApRankingStrategy.apFractional

    ' Expected error codes to accept.
    Const CannotAddKey      As Long = 457
    Const CannotFindKey     As Long = 5
    ' Uncommon character string to assemble Key and SubKey as a compound key.
    Const KeySeparator      As String = "¤§¤"

    ' Array of the collections for the five strategies.
    Static Ranks(FirstStrategy To LastStrategy) As Collection
    ' The last sort order used.
    Static LastOrder        As ApRankingOrder

    Dim Records             As DAO.Recordset

    ' Array to hold the rank for each strategy.
    Dim Rank(FirstStrategy To LastStrategy)     As Double

    Dim Item                As Integer
    Dim Sql                 As String
    Dim SortCount           As Integer
    Dim SortOrder           As String
    Dim LastKey             As String
    Dim Key                 As String
    Dim SubKey              As String
    Dim Dupes               As Integer
    Dim Delta               As Long
    Dim ThisStrategy        As ApRankingStrategy

    On Error GoTo Err_RowRank

    If Expression = "" Then
        ' Erase the collections of keys.
        For Item = LBound(Ranks) To UBound(Ranks)
            Set Ranks(Item) = Nothing
        Next
    Else
        If LastOrder <> Order Or Ranks(FirstStrategy) Is Nothing Then
            ' Initialize the collections and reset their ranks.
            For Item = LBound(Ranks) To UBound(Ranks)
                Set Ranks(Item) = New Collection
                Rank(Item) = 0
            Next

            ' Build order clause.
            Sql = Replace(Replace(SqlMask1, "{0}", Expression), "{1}", Domain)
            SortCount = CurrentDb.OpenRecordset(Sql, dbReadOnly).Fields.Count

            If Order = ApRankingOrder.apDescending Then
                ' Descending sorting (default).
                SortOrder = OrderDesc
            Else
                ' Ascending sorting.
                SortOrder = OrderAsc
            End If
            LastOrder = Order

            ' Build SQL.
            Sql = Replace(Replace(Replace(SqlMask, "{0}", Expression), "{1}", Domain), "{2}", SortOrder)
            ' Add a second sort field, if present.
            If SortCount >= 2 Then
                Sql = Sql & Replace(Replace(SqlOrder, "{0}", 2), "{1}", SortOrder)
            End If

            ' Open ordered recordset.
            Set Records = CurrentDb.OpenRecordset(Sql, dbReadOnly)
            ' Loop the recordset once while creating all the collections of ranks.
            While Not Records.EOF
                Key = CStr(Nz(Records.Fields(0).Value))
                SubKey = ""
                ' Create the sub key if a second field is present.
                If SortCount > 1 Then
                    SubKey = CStr(Nz(Records.Fields(1).Value))
                End If

                If LastKey <> Key Then
                    ' Add new entries.
                    For ThisStrategy = FirstStrategy To LastStrategy
                        Select Case ThisStrategy
                            Case ApRankingStrategy.apDense
                                Rank(ThisStrategy) = Rank(ThisStrategy) + 1
                            Case ApRankingStrategy.apStandardCompetition
                                Rank(ThisStrategy) = Rank(ThisStrategy) + 1 + Dupes
                                Dupes = 0
                            Case ApRankingStrategy.apModifiedCompetition
                                Rank(ThisStrategy) = Rank(ThisStrategy) + 1
                            Case ApRankingStrategy.apOrdinal
                                Rank(ThisStrategy) = Rank(ThisStrategy) + 1
                                ' Add entry using both Key and SubKey
                                Ranks(ThisStrategy).Add Rank(ThisStrategy), Key & KeySeparator & SubKey
                            Case ApRankingStrategy.apFractional
                                Rank(ThisStrategy) = Rank(ThisStrategy) + 1 + Delta / 2
                                Delta = 0
                        End Select
                        If ThisStrategy = ApRankingStrategy.apOrdinal Then
                            ' Key with SubKey has been added above for this strategy.
                        Else
                            ' Add key for all other strategies.
                            Ranks(ThisStrategy).Add Rank(ThisStrategy), Key
                        End If
                    Next
                    LastKey = Key
                Else
                    ' Modify entries and/or counters for those strategies that require this for a repeated key.
                    For ThisStrategy = FirstStrategy To LastStrategy
                        Select Case ThisStrategy
                            Case ApRankingStrategy.apDense
                            Case ApRankingStrategy.apStandardCompetition
                                Dupes = Dupes + 1
                            Case ApRankingStrategy.apModifiedCompetition
                                Rank(ThisStrategy) = Rank(ThisStrategy) + 1
                                Ranks(ThisStrategy).Remove Key
                                Ranks(ThisStrategy).Add Rank(ThisStrategy), Key
                            Case ApRankingStrategy.apOrdinal
                                Rank(ThisStrategy) = Rank(ThisStrategy) + 1
                                ' Will fail for a repeated value of SubKey.
                                Ranks(ThisStrategy).Add Rank(ThisStrategy), Key & KeySeparator & SubKey
                            Case ApRankingStrategy.apFractional
                                Rank(ThisStrategy) = Rank(ThisStrategy) + 0.5
                                Ranks(ThisStrategy).Remove Key
                                Ranks(ThisStrategy).Add Rank(ThisStrategy), Key
                                Delta = Delta + 1
                        End Select
                    Next
                End If
                Records.MoveNext
            Wend
            Records.Close
        End If

        ' Retrieve the rank for the current strategy.
        If Strategy = ApRankingStrategy.apOrdinal Then
            ' Use both Value and SubValue.
            Key = CStr(Nz(Value)) & KeySeparator & CStr(Nz(SubValue))
        Else
            ' Use Value only.
            Key = CStr(Nz(Value))
        End If
        ' Will fail if key isn't present.
        Rank(Strategy) = Ranks(Strategy).Item(Key)
    End If

    RowRank = Rank(Strategy)

Exit_RowRank:
    Exit Function

Err_RowRank:
    Select Case Err
        Case CannotAddKey
            ' Key is present, thus cannot be added again.
            Resume Next
        Case CannotFindKey
            ' Key is not present, thus cannot be removed.
            Resume Next
        Case Else
            ' Some other error. Ignore.
            Resume Exit_RowRank
    End Select

End Function

Полный код, документацию и демонстрационную версию для загрузки на GitHub : VBA. RowNumbers

Просмотрите пункт 5 в файле ReadMe.