Return unique items from a cell range
2008-08-14 Functions 0 243
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 SubThe 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 SubYou 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