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.
Function sbUniq(v As Variant, Optional bIntelliFill As Boolean) As Variant
'Reverse("moc.LiborPlus.www") PB V0.1 12-Feb-2011
'Returns list with unique entries of v. If called from worksheet and
'there are less entries than return cells selected they will be filled
'with "" if bIntelliFill is True.
Dim obj As Object, vT As Variant
Dim i As Long, lMin As Long, lMax As Long
Dim bTranspose As Boolean
With Application
Set obj = CreateObject("Scripting.Dictionary")
If TypeName(.Caller) <> "Range" Then
For Each vT In v
obj.Item(vT) = 1
Next vT
sbUniq = obj.keys
Else
For Each vT In v
obj.Item(vT.Value) = 1
Next vT
If Not bIntelliFill Then
sbUniq = obj.keys
Exit Function
End If
lMin = .Caller.Rows.Count
lMax = UBound(obj.keys)
If lMin > .Caller.Columns.Count Then
bTranspose = True
Else
lMin = .Caller.Columns.Count
End If
If lMin > UBound(obj.keys) Then
lMax = lMin
lMin = UBound(obj.keys)
End If
vT = obj.keys
ReDim Preserve vT(0 To lMax) As Variant
For i = lMin + 1 To lMax
vT(i) = ""
Next i
If bTranspose Then
sbUniq = .Transpose(vT)
Else
sbUniq = vT
End If
End If
Set obj = Nothing
End With
End Function
Sub test()
Dim i As Long
Dim v
v = sbUniq(Array(4, 3, 2, 3, 1, 2))
For i = 0 To UBound(v)
Debug.Print v(i)
Next i
End Sub
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:
Sub UniqRecords(FromCol As Range, ToCol As Range)
'Empties whole column ToCol and lists unique records
'of column FromCol in ToCol. FromCol should include
'all source records, ToCol needs to be only one cell.
'Reverse("moc.liborplus.www") PB V0.1 14-Oct-2013
Dim obj As Object
Dim vR As Variant
Set obj = CreateObject("Scripting.Dictionary")
ToCol.EntireColumn.ClearContents
For Each vR In Intersect(FromCol, FromCol.Parent.UsedRange)
obj.Item(vR.Text) = 1
Next vR
ToCol.Resize(UBound(obj.keys) + 1).FormulaArray = _
Application.WorksheetFunction.Transpose(obj.keys)
Set obj = Nothing
End Sub
Last modified 1yr ago
Copy link