|
|||||||
These pages are no longer updated and are only available for archive purposes.Click here to visit the pages with updated information. Return unique items from a cell rangeThe macro below will return a collection with the unique items from a cell range. 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
|
|||||||
|