Ranking without preset Excel function.

[a.riva@UCL]

Hi guys!

An other question for you.

I would like to create a new UDF with VBA which could allow me to
determine the rank of a number within an array.

I know that Excel already has a function (WorksheetFunction.Rank())
that does that. But this function requires the second argument to be
declared as Range. Therefore I cannot use this function in the context
of UDFs where I use array variables, because if I use an array as the
second argument I get a ByRef error. I do not want to assign my array
to a range on the worksheet, but I simply want to use my array as
reference for the ranking procedure.

How can I re-write the ranking procedure without using the Rank built-
in function, so that I can use an array as reference?

Thank you very much!!!

Antonio.

 

[Alan Beban]

Hi guys!

An other question for you.

I would like to create a new UDF with VBA which could allow me to
determine the rank of a number within an array.

I know that Excel already has a function (WorksheetFunction.Rank())
that does that. But this function requires the second argument to be
declared as Range. Therefore I cannot use this function in the context
of UDFs where I use array variables, because if I use an array as the
second argument I get a ByRef error. I do not want to assign my array
to a range on the worksheet, but I simply want to use my array as
reference for the ranking procedure.

How can I re-write the ranking procedure without using the Rank built-
in function, so that I can use an array as reference?

Thank you very much!!!

Antonio.

If the functions in the freely downloadable file at
http://home.pacbell.net/beban are available to your workbook

ArrayCountIf(arr,value,">") + 1 for arr as if sorted descending
ArrayCountIf(arr,value,"<") + 1 for arr as if sorted ascending

Or, to make it more analogous to the worksheet function RANK in order of
parameters

Function ArrayRank(varValue, varArray, Optional varOrder = 0)
If IsMissing(varOrder) Or varOrder = 0 Then
ArrayRank = ArrayCountIf(varArray, varValue, ">") + 1
Else
ArrayRank = ArrayCountIf(varArray, varValue, "<") + 1
End If
End Function

I've left the error checking in the function to the reader.

Alan Beban

 

[Alan Beban]

Function ArrayRank(varValue, varArray, Optional varOrder = 0)
If IsMissing(varOrder) Or varOrder = 0 Then
ArrayRank = ArrayCountIf(varArray, varValue, ">") + 1
Else
ArrayRank = ArrayCountIf(varArray, varValue, "<") + 1
End If
End Function

I've left the error checking in the function to the reader.

Alan Beban

The above first line is silly; just use

If varOrder = 0 Then

Alan Beban

 

[Alan Beban]

The above function has the limited use sought by the OP's original
illustration, i.e., ArrayRank([some number], varArray, Optional varOrder
= 0). If one is going to use such a function, it should have the
capability of accepting a range or array as the first parameter, in the
same way that the array formula version of the RANK function accepts a
range. I'll be working on this, along with the associated error checking.

Alan Beban

 

[a.riva@UCL]

Thanks Alan.

I'll download the file straight away! And I'll try the code

Cheers!!!


Antonio.

The above function has the limited use sought by the OP's original
illustration, i.e., ArrayRank([some number], varArray, Optional varOrder
= 0). If one is going to use such a function, it should have the
capability of accepting a range or array as the first parameter, in the
same way that the array formula version of the RANK function accepts a
range. I'll be working on this, along with the associated error checking.

Alan Beban

 

[Alan Beban]

For the time being the ArrayRank function, for your use, should be

Function ArrayRank(varValue, varArray, Optional varOrder = 0)
If Application.IsNA(Application.Match(varValue, varArray, 0)) Then
ArrayRank = "#N/A"
ElseIf varOrder = 0 Then
ArrayRank = ArrayCountIf(varArray, varValue, ">") + 1
Else
ArrayRank = ArrayCountIf(varArray, varValue, "<") + 1
End If
End Function

That way ArrayRank will return #N/A if varValue is not in varArray;
that's how the RANK function works. And without the additional first
two lines, the ArrayRank function would return a rank of 1 for any
missing value.

Alan Beban

Thanks Alan.

I'll download the file straight away! And I'll try the code

Cheers!!!


Antonio.

Alan Beban wrote:

Function ArrayRank(varValue, varArray, Optional varOrder = 0)
If varOrder = 0 Then
ArrayRank = ArrayCountIf(varArray, varValue, ">") + 1
Else
ArrayRank = ArrayCountIf(varArray, varValue, "<") + 1
End If
End Function

I've left the error checking in the function to the reader.

Alan Beban

The above function has the limited use sought by the OP's original
illustration, i.e., ArrayRank([some number], varArray, Optional varOrder
= 0). If one is going to use such a function, it should have the
capability of accepting a range or array as the first parameter, in the
same way that the array formula version of the RANK function accepts a
range. I'll be working on this, along with the associated error checking.

Alan Beban

 

[Dana DeLouis]

How can I re-write the ranking procedure without using the Rank built-

in function, so that I can use an array as reference?

This general idea uses the Small functon, but Alan may have something more
efficient.
Change to "Large" if you want descending order. Again, just a general idea.

Sub TestIt()
Dim sol
'Returns: 5
sol = RankArray(55, Array(11, 55, 33, 22, 66, 44))
End Sub


Function RankArray(n, v)
Dim j, k
Dim Os 'Offset

Os = 1 - LBound(v)
With WorksheetFunction
For j = LBound(v) To UBound(v)
k = .Small(v, j + Os)
If k = n Then
RankArray = j + Os
Exit Function
End If
Next
End With
RankArray = "#N/A"
End Function

 

[Alan Beban]

Thanks Alan.

I'll download the file straight away! And I'll try the code

Cheers!!!


Antonio.

Here is a more general function that is intended to mirror with arrays
(or ranges, for that matter) the operation of the RANK worksheet
function; watch for wordwrap. It depends on other functions in the
freely downloadable file at http://home.pacbell.net/beban.

Constructive comments welcome.

Function ArrayRank(varValue, varArray, Optional varOrder = 0)
'This function is designed to operate on arrays as the
'worksheet RANK function operates on ranges.

Dim arrOut, numDimsV As Integer, i As Long, j As Long
Dim varArrayDupe, varValueDupe

'Return a single rank for a single variable.
If Not IsArray(varValue) Then
'Reject non-numeric input.
If Not IsNumeric(varValue) Then
Msg = "the first input parameter must be a number" & _
"or a range or array of numbers."
MsgBox Msg, 16
Exit Function
End If

If Application.IsNA(Application.Match(varValue, varArray, 0)) Then
ArrayRank = "#N/A"
ElseIf varOrder = 0 Then
ArrayRank = ArrayCountIf(varArray, varValue, ">") + 1
Else
ArrayRank = ArrayCountIf(varArray, varValue, "<") + 1
End If
Else

'Convert ranges, if any, to arrays
varArray = varArray
varValue = varValue

'To insure numeric values, convert input to Long() type arrays
ReDim varArrayDupe(1) As Long
ReDim varValueDupe(1) As Long

'Assign varValue to a Long() type array
xV = Assign(varValue, varValueDupe)

'If varValue contains values not convertible to Longs, the
'assignment will fail, so
If xV = False Then Exit Function

'Assign varArray to a Long() type array
xA = Assign(varArray, varArrayDupe)

'If varArray contains values not convertible to Longs, the
'assignment will fail, so
If xA = False Then Exit Function

numDimsV = ArrayDimensions(varValueDupe)

Select Case numDimsV
'If the input values to be ranked are in a 1-dimensional array,
return
'a same sized 1-dimensional array of rank values.
Case 1
'Load a 1-dimensional output array.
ReDim arrOut(LBound(varValueDupe) To UBound(varValueDupe) -
LBound(varValueDupe) + 1)
For i = LBound(varValueDupe) To UBound(varValueDupe) -
LBound(varValueDupe) + 1
If varOrder = 0 Then
If IsError(ArrayMatch(varValueDupe(i),
varArrayDupe)) Then
arrOut(i) = "#N/A"
Else
arrOut(i) = ArrayCountIf(varArrayDupe,
varValueDupe(i), ">") + 1
End If
Else
If IsError(ArrayMatch(varValueDupe(i),
varArrayDupe)) Then
arrOut(i) = "#N/A"
Else
arrOut(i) = ArrayCountIf(varArrayDupe,
varValueDupe(i), "<") + 1
End If
End If
i = i + 1
Next
'If the input values to be ranked are in a 2-dimensional array,
return
'a same sized 2-dimensional array of rank values.
Case 2
'Load a 2-dimensional output array.
ReDim arrOut(LBound(varValueDupe) To UBound(varValueDupe) -
LBound(varValueDupe) + 1, _
LBound(varValueDupe, 2) To UBound(varValueDupe,
2) - LBound(varValueDupe, 2) + 1)
For i = LBound(varValue) To UBound(varValue) -
LBound(varValue) + 1
For j = LBound(varValueDupe, 2) To UBound(varValueDupe,
2) - LBound(varValueDupe, 2) + 1
If varOrder = 0 Then
If IsError(ArrayMatch(varValueDupe(i, j),
varArrayDupe)) Then
arrOut(i, j) = "#N/A"
Else
arrOut(i, j) = ArrayCountIf(varArrayDupe,
varValueDupe(i, j), ">") + 1
End If
Else
If IsError(ArrayMatch(varValueDupe(i, j),
varArrayDupe)) Then
arrOut(i, j) = "#N/A"
Else
arrOut(i, j) = ArrayCountIf(varArrayDupe,
varValueDupe(i, j), "<") + 1
End If
End If
Next
Next
End Select
ArrayRank = arrOut
End If
End Function

Alan Beban

 

[Alan Beban]

Here is a more general function that is intended to mirror with arrays
(or ranges, for that matter) the operation of the RANK worksheet
function; watch for wordwrap. It depends on other functions in the
freely downloadable file at http://home.pacbell.net/beban.

Constructive comments welcome.

My previous posting of the general function had a spurious i=i+1 in it;
here it is with the correction:

Function ArrayRank(varValue, varArray, Optional varOrder = 0)
'This function is designed to operate on arrays as the
'worksheet RANK function operates on ranges.

Dim arrOut, numDimsV As Integer, i As Long, j As Long
Dim varArrayDupe, varValueDupe

'Return a single rank for a single variable.
If Not IsArray(varValue) Then
'Reject non-numeric input.
If Not IsNumeric(varValue) Then
Msg = "the first input parameter must be a number" & _
"or a range or array of numbers."
MsgBox Msg, 16
Exit Function
End If

If Application.IsNA(Application.Match(varValue, varArray, 0)) Then
ArrayRank = "#N/A"
ElseIf varOrder = 0 Then
ArrayRank = ArrayCountIf(varArray, varValue, ">") + 1
Else
ArrayRank = ArrayCountIf(varArray, varValue, "<") + 1
End If
Else

'Convert ranges, if any, to arrays
varArray = varArray
varValue = varValue

'To insure numeric values, convert input to Long() type arrays
ReDim varArrayDupe(1) As Long
ReDim varValueDupe(1) As Long

'Assign varValue to a Long() type array
xV = Assign(varValue, varValueDupe)

'If varValue contains values not convertible to Longs, the
'assignment will fail, so
If xV = False Then Exit Function

'Assign varArray to a Long() type array
xA = Assign(varArray, varArrayDupe)

'If varArray contains values not convertible to Longs, the
'assignment will fail, so
If xA = False Then Exit Function

numDimsV = ArrayDimensions(varValueDupe)

Select Case numDimsV
'If the input values to be ranked are in a 1-dimensional array,
return
'a same sized 1-dimensional array of rank values.
Case 1
'Load a 1-dimensional output array.
ReDim arrOut(LBound(varValueDupe) To UBound(varValueDupe) -
LBound(varValueDupe) + 1)
For i = LBound(varValueDupe) To UBound(varValueDupe) -
LBound(varValueDupe) + 1
If varOrder = 0 Then
If IsError(ArrayMatch(varValueDupe(i),
varArrayDupe)) Then
arrOut(i) = "#N/A"
Else
arrOut(i) = ArrayCountIf(varArrayDupe,
varValueDupe(i), ">") + 1
End If
Else
If IsError(ArrayMatch(varValueDupe(i),
varArrayDupe)) Then
arrOut(i) = "#N/A"
Else
arrOut(i) = ArrayCountIf(varArrayDupe,
varValueDupe(i), "<") + 1
End If
End If
Next
'If the input values to be ranked are in a 2-dimensional array,
return
'a same sized 2-dimensional array of rank values.
Case 2
'Load a 2-dimensional output array.
ReDim arrOut(LBound(varValueDupe) To UBound(varValueDupe) -
LBound(varValueDupe) + 1, _
LBound(varValueDupe, 2) To UBound(varValueDupe,
2) - LBound(varValueDupe, 2) + 1)
For i = LBound(varValue) To UBound(varValue) -
LBound(varValue) + 1
For j = LBound(varValueDupe, 2) To UBound(varValueDupe,
2) - LBound(varValueDupe, 2) + 1
If varOrder = 0 Then
If IsError(ArrayMatch(varValueDupe(i, j),
varArrayDupe)) Then
arrOut(i, j) = "#N/A"
Else
arrOut(i, j) = ArrayCountIf(varArrayDupe,
varValueDupe(i, j), ">") + 1
End If
Else
If IsError(ArrayMatch(varValueDupe(i, j),
varArrayDupe)) Then
arrOut(i, j) = "#N/A"
Else
arrOut(i, j) = ArrayCountIf(varArrayDupe,
varValueDupe(i, j), "<") + 1
End If
End If
Next
Next
End Select
ArrayRank = arrOut
End If
End Function

Alan Beban

 

[a.riva@UCL]

Thanks for all the suggestions!

The code that Dana sent is working very well, and it's really
simple

Now I have an other question...

I have my usual option-based-1 array1 in VBA, which contains x
numbers. Some of them are repeated. What I would like to do is
creating an other option-based-1 array, let's call it array2, which
contains the numbers of occurrences of each of the repeated elements
of array1 within array1... I'm struggling to find a solution...

For example:

option-based-1 array1 is (1, 2, 4, 6, 5, 4, 7, 2, 3, 2, 3) --> I
cannot sort the array.

I think that the procedure should do the following operation: it
detects how many items are repeated in "array1", and for each of this
repeated items stores in a new array "array2" a number corresponding
to the number of its occurrences.

For example, in array1 the procedure detects that there are n=3 items
which occur more than once (they are "2", "4" and "3"). Then it ReDims
array2 (1 to n), and for i=1 to n it gives to array2(i) the values of:

i=1 --> array2(1) = 3 (occurrences of "2"),
i=2 --> array2(2) = 2 (occurrences of "4"),
i=3 --> array2(3) = 2 (occurrences of "3").

Can somebody help me?

Thanks in advance

Antonio.

 

[Dana DeLouis]

i=1 --> array2(1) = 3 (occurrences of "2"),

i=2 --> array2(2) = 2 (occurrences of "4"),
i=3 --> array2(3) = 2 (occurrences of "3").

Hi. One idea is to use a Dictionary Object. Here is a general idea.
I understand you only want an array of those items with a count >1.

Sub Demo_Tally()
Dim d
Dim p
Dim n, k
Dim v
v = Array(1, 2, 4, 6, 5, 4, 7, 2, 3, 2, 3)

Set d = CreateObject("Scripting.Dictionary")
' Add Key, Item (Both Required)

'// Tally items
For p = LBound(v) To UBound(v)
n = v(p)
If d.exists(n) Then
d(n) = d(n) + 1
Else
d.Add n, 1
End If
Next p

'// Remove items with Count = 1
For Each k In d.keys
If d(k) = 1 Then d.Remove (k)
Next k

'// Display items
For Each k In d.keys
Debug.Print k, d(k)
Next k
End Sub


Returns:
Item | Count
2 3
4 2
3 2