RANK.AVG Excel MS Access 中的函数
RANK.AVG Excel function inside MS Access
我正在尝试在我的 MS ACCESS VBA 代码中使用 Excel 函数 RANK.AVG，但它给了我 运行-时间错误“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
您不需要 Excel。可以使用 collection:
在 Access 中完成
' 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 段。
尽管 VBA 提供的数组处理工具很少，但您可以自己对数组进行排名，因此需要相当多的辅助函数。排名的实际逻辑并不复杂，因此很容易实现。
主要功能：
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），但如果你有一个数组，它会比大多数其他解决方案更快内存。
我正在尝试在我的 MS ACCESS VBA 代码中使用 Excel 函数 RANK.AVG，但它给了我 运行-时间错误“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
您不需要 Excel。可以使用 collection:
在 Access 中完成' 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 段。
尽管 VBA 提供的数组处理工具很少，但您可以自己对数组进行排名，因此需要相当多的辅助函数。排名的实际逻辑并不复杂，因此很容易实现。
主要功能：
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），但如果你有一个数组，它会比大多数其他解决方案更快内存。