Return unique items from a cell range

The macro below will return a collection with the unique items from a cell range.
The collection can optionally be populated with separate keys and values.

Function GetUniqueItems(KeyRange As Range, Optional ItemRange As Range) As Collection
Dim r As Long, c As Long, varItem As Variant, strKey As String
    If Not KeyRange Is Nothing Then
        Set GetUniqueItems = New Collection
        With KeyRange
            For c = 1 To .Columns.Count
                For r = 1 To .Rows.Count
                    strKey = vbNullString
                    varItem = vbNullString
                    On Error Resume Next
                    strKey = Trim(CStr(.Cells(r, c).Value))
                    If Not ItemRange Is Nothing Then
                        varItem = ItemRange.Cells(r, c).Value
                    Else
                        varItem = .Cells(r, c).Value
                    End If
                    If Len(strKey) > 0 Then
                        GetUniqueItems.Add varItem, strKey
                    End If
                    On Error GoTo 0
                Next r
                DoEvents
            Next c
        End With
        If GetUniqueItems.Count = 0 Then
            Set GetUniqueItems = Nothing
        End If
    End If
End Function

Sub TestCopyUniqueItems()
Dim coll As Collection, i As Long
    Set coll = GetUniqueItems(Range("A1:A100"))
    If coll Is Nothing Then Exit Sub
    
    Range("C1:C100").Clear
    For i = 1 To coll.Count
        Range("C1").Offset(i - 1, 0).Formula = coll(i)
    Next i
End Sub

The macro below will use the built in filter functionality in Excel to return all the unique items from a range to another range:

Sub FindUniqueValues(SourceRange As Range, TargetCell As Range)
    SourceRange.AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=TargetCell,  Unique:=True
End Sub

You can use the macro like this to copy all the unique items from A1:A100 to cell C1 and below:

Sub TestFindUniqueValues()
    FindUniqueValues Range("A1:A100"), Range("C1")
End Sub

Document last updated 2008-08-14 21:54:29 Printerfriendly version

User comments:

Ole P. from Norway wrote (2005-09-19 09:03:41 CET):

Re: Update that allows working with formulas instead of values
The original solutions works on cell ranges containing formulas, except when the first cell (the heading) contains a formula that returns a different result when copied to another location.

Cesar Mugnatto wrote (2005-09-15 18:56:32 CET):

Update that allows working with formulas instead of values
The solution above does not work when the SourceRange contains formulas. Instead, you get errors that are impossible to figure out due to microsoft's poor documentation. Anyway, the solution is to copy the values in SourceRange, so...

Sub FindUniqueValues(SourceRange As Range, ValueRange as Range, TargetCell As Range)
Dim currRange as Range
Application.ScreenUpdating = False
Set currRange = ActiveCell
SourceRange.Copy
ValueRange.PasteSpecial xlPasteValues
ValueRange.AdvancedFilter xlFilterCopy, , TargetCell, True
Application.GotoRange currRange
Application.ScreenUpdating = True
End Sub