Abstract

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 "" seemed to be useful.

Appendix – sbUniq Code

Please read my Disclaimer.

Option Explicit

Function sbUniq(v As Variant, Optional bIntelliFill As Boolean) As Variant
'Source (DE): http://www.bplumhoff.de/sbuniq_de/
'Source (EN): http://www.sulprobil.com/sbuniq_en/
'(C) (P) by Bernd Plumhoff 12-Feb-2011 PB V0.1
'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

Rank without Gaps

With sbUniq you can now easily create a rank function without gaps, for example:

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!

Copy Unique Records from one Column to Another

In case you need a Sub to copy all unique records from a column to another one:

Please read my Disclaimer.

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