Sulprobil
Search…
sbUniq
Use worksheet function UNIQUE from Excel 365 onwards
Before Excel 365 Excel lacked a function to create a list of unique entries. Since such a function comes in very handy every now and then - just think about drop-down lists or lists for data validation - I created one:
An optional parameter which fills unused cells of the output range with "" seems to be useful.
Please read my Disclaimer.
1
Function sbUniq(v As Variant, Optional bIntelliFill As Boolean) As Variant
2
'Reverse("moc.LiborPlus.www") PB V0.1 12-Feb-2011
3
'Returns list with unique entries of v. If called from worksheet and
4
'there are less entries than return cells selected they will be filled
5
'with "" if bIntelliFill is True.
6
Dim obj As Object, vT As Variant
7
Dim i As Long, lMin As Long, lMax As Long
8
Dim bTranspose As Boolean
9
With Application
10
Set obj = CreateObject("Scripting.Dictionary")
11
If TypeName(.Caller) <> "Range" Then
12
For Each vT In v
13
obj.Item(vT) = 1
14
Next vT
15
sbUniq = obj.keys
16
Else
17
For Each vT In v
18
obj.Item(vT.Value) = 1
19
Next vT
20
If Not bIntelliFill Then
21
sbUniq = obj.keys
22
Exit Function
23
End If
24
lMin = .Caller.Rows.Count
25
lMax = UBound(obj.keys)
26
If lMin > .Caller.Columns.Count Then
27
bTranspose = True
28
Else
29
lMin = .Caller.Columns.Count
30
End If
31
If lMin > UBound(obj.keys) Then
32
lMax = lMin
33
lMin = UBound(obj.keys)
34
End If
35
vT = obj.keys
36
ReDim Preserve vT(0 To lMax) As Variant
37
For i = lMin + 1 To lMax
38
vT(i) = ""
39
Next i
40
If bTranspose Then
41
sbUniq = .Transpose(vT)
42
Else
43
sbUniq = vT
44
End If
45
End If
46
Set obj = Nothing
47
End With
48
End Function
49
50
Sub test()
51
Dim i As Long
52
Dim v
53
v = sbUniq(Array(4, 3, 2, 3, 1, 2))
54
For i = 0 To UBound(v)
55
Debug.Print v(i)
56
Next i
57
End Sub
Copied!
With sbUniq you can now easily create a rank function without gaps, for example:
If you can only use worksheet functions, have a look here.
If you have a huge file with plenty of data you can minimise the runtime by creating a sorted list of unique entries (do not take my UDF sbGSort - take Excel's internal sort or from Excel 365 onwards take the new worksheet function SORT) and then match all input values: In cell D2 you would enter =MATCH(A2,$C$2:$C$15,1) and copy down. To inverse the rank order you just need to sort the unique entries descending - but keep in mind that you need to change the last parameter of MATCH to -1!
Other rank solutions I present here.
In case you need a Sub to copy all unique records from a column to another one:
1
Sub UniqRecords(FromCol As Range, ToCol As Range)
2
'Empties whole column ToCol and lists unique records
3
'of column FromCol in ToCol. FromCol should include
4
'all source records, ToCol needs to be only one cell.
5
'Reverse("moc.liborplus.www") PB V0.1 14-Oct-2013
6
Dim obj As Object
7
Dim vR As Variant
8
9
Set obj = CreateObject("Scripting.Dictionary")
10
ToCol.EntireColumn.ClearContents
11
For Each vR In Intersect(FromCol, FromCol.Parent.UsedRange)
12
obj.Item(vR.Text) = 1
13
Next vR
14
ToCol.Resize(UBound(obj.keys) + 1).FormulaArray = _
15
Application.WorksheetFunction.Transpose(obj.keys)
16
Set obj = Nothing
17
End Sub
Copied!
Last modified 1yr ago
Copy link