Sulprobil
Search…
sbUniqRank
You need a rank function which returns a unique rank, even if duplicates occur? One possible approach:
You need to press ALT + F11, insert a new module and copy the program code below into the new module, then return to your spreadsheet, select cells A12:C15 and enter =sbUniqRank(A2:C5) with CTRL + SHIFT + ENTER as an array formula.
Please read my Disclaimer.
1
Function sbUniqRank(r As Range, _
2
Optional vCountFrom As Variant = 1, _
3
Optional bJustNumeric As Boolean = True, _
4
Optional lOrder As Long = 0) As Variant
5
'Reverse("moc.liborplus.www") PB V0.6 25-Oct-2018
6
'Array function to rank a range with unique ranks.
7
'vCountFrom determines from where you count in case of duplicates:
8
'1 = first rows (1 to count), then columns (1 to count), i. e. top left to top right (tltr)
9
'2 = starting with top right to top left, then downwards (trtl)
10
'...
11
'8 = starting with bottom right to top right, then to the left (brtr)
12
'If bJustNumeric is True then Rank will be used to rank, if False then Countif will be used.
13
'lOrder is like Rank's order: 0 = Descending, 1 = Ascending
14
Dim obj As Object
15
Dim bSwap As Boolean
16
Dim i As Long, i1 As Long, i2 As Long, i3 As Long
17
Dim j As Long, j1 As Long, j2 As Long, j3 As Long
18
Dim sComp As String
19
Dim vI As Variant, vR As Variant
20
vI = r: vR = vI
21
Set obj = CreateObject("Scripting.Dictionary")
22
Select Case vCountFrom
23
Case 1, "tltr", "olor"
24
i1 = 1: i2 = UBound(vI, 1): i3 = 1: j1 = 1: j2 = UBound(vI, 2): j3 = 1: bSwap = False
25
Case 2, "trtl", "orol"
26
i1 = 1: i2 = UBound(vI, 1): i3 = 1: j1 = UBound(vI, 2): j2 = 1: j3 = -1: bSwap = False
27
Case 3, "blbr", "ulur"
28
i1 = UBound(vI, 1): i2 = 1: i3 = -1: j1 = 1: j2 = UBound(vI, 2): j3 = 1: bSwap = False
29
Case 4, "brbl", "urul"
30
i1 = UBound(vI, 1): i2 = 1: i3 = -1: j1 = UBound(vI, 2): j2 = 1: j3 = -1: bSwap = False
31
Case 5, "tlbl", "olul"
32
i1 = 1: i2 = UBound(vI, 2): i3 = 1: j1 = 1: j2 = UBound(vI, 1): j3 = 1: bSwap = True
33
Case 6, "bltl", "ulol"
34
i1 = 1: i2 = UBound(vI, 2): i3 = 1: j1 = UBound(vI, 1): j2 = 1: j3 = -1: bSwap = True
35
Case 7, "trbr", "orur"
36
i1 = UBound(vI, 2): i2 = 1: i3 = -1: j1 = 1: j2 = UBound(vI, 1): j3 = 1: bSwap = True
37
Case 8, "brtr", "uror"
38
i1 = UBound(vI, 2): i2 = 1: i3 = -1: j1 = UBound(vI, 1): j2 = 1: j3 = -1: bSwap = True
39
Case Else
40
sbUniqRank = CVErr(xlErrValue)
41
Exit Function
42
End Select
43
sComp = ">": If lOrder = 1 Then sComp = "<"
44
If bSwap Then
45
'column - wise
46
For i = i1 To i2 Step i3
47
For j = j1 To j2 Step j3
48
If bJustNumeric Then
49
vR(j, i) = Application.WorksheetFunction.Rank(vI(j, i), r, lOrder) _
50
+ obj.Item(vI(j, i))
51
Else
52
vR(j, i) = Application.WorksheetFunction.CountIf(r, _
53
sComp & vI(j, i)) + obj.Item(vI(j, i)) + 1
54
End If
55
obj.Item(vI(j, i)) = obj.Item(vI(j, i)) + 1
56
Next j
57
Next i
58
Else
59
'row - wise
60
For i = i1 To i2 Step i3
61
For j = j1 To j2 Step j3
62
If bJustNumeric Then
63
vR(i, j) = Application.WorksheetFunction.Rank(vI(i, j), r, lOrder) _
64
+ obj.Item(vI(i, j))
65
Else
66
vR(i, j) = Application.WorksheetFunction.CountIf(r, _
67
sComp & vI(i, j)) + obj.Item(vI(i, j)) + 1
68
End If
69
obj.Item(vI(i, j)) = obj.Item(vI(i, j)) + 1
70
Next j
71
Next i
72
End If
73
sbUniqRank = vR
74
End Function
Copied!
sbUniqRank.xlsm
80KB
Binary
sbUniqRank.xlsm
For a worksheet function approach please look at Rank.
Last modified 1yr ago
Copy link