Return unique items from a cell range

 2008-08-14    Functions    0    77

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


Leave a comment:

Your comment will only be published after it has been moderated and found spam free.
Your e-mail address will only be used to display your Gravatar.