Unique Item Function

[dennisli]

In Excel, you can use Advanced Autofilter to get unique value, is it possible to get unique item using one custom function or combined built in functions given a range?
For example, given a range A10:A100, from cell B10 and down, you can get the unique item? Like UniqueItem(A$10:A$100). B10 if for first unique data, B11 is for second unique data.
Thanks lot.
Dennis

 

[iliace]

Adapted from a function in this article: http://msdn.microsoft.com/en-us/library/aa730921.aspx

Public Function UniqueValues(theRange As Range) As Variant
    Dim colUniques As New VBA.Collection
    Dim vArr As Variant
    Dim vCell As Variant
    Dim vLcell As Variant
    Dim oRng As Excel.Range
    Dim i As Long
    Dim vUnique As Variant
    Set oRng = Intersect(theRange, theRange.Parent.UsedRange)
    vArr = oRng
    On Error Resume Next
    For Each vCell In vArr
    If vCell <> vLcell Then
        If Len(CStr(vCell)) > 0 Then
             colUniques.Add vCell, CStr(vCell)
        End If
    End If
    vLcell = vCell
    Next vCell
    On Error GoTo 0
 
    ReDim vUnique(1 To colUniques.Count)
    For i = LBound(vUnique) To UBound(vUnique)
      vUnique(i) = colUniques(i)
    Next i
 
    UniqueValues = vUnique
End Function

Use as an array formula. So for instance, when my list of values is B5:B69, I select D14:Q14, then type =UniqueValues(B5:B69) and press Ctrl+Shift+Enter. If you select more cells than there are unique values you'll get #N/A for the extras.

 

[DonkeyOte]

Slightly different approach -- would return unique x value, ie

=UNIQUE($A$10:$A$100,1) would return first unique value in the in the range.

could adjust 1 obviously ie UNIQUE(A10:A100,ROW(B10)-9) which you could copy down (would return 0 where no unique value exists), however, if you want the range returned in one go then iliace's solution is certainly the one for you... if want to return say the xth unique value into a given cell then this would work.

Function Unique(f_rng, rnk As Long)
Dim cell As Range
Dim f_str As String
Dim f_i As Integer
Dim ans As Variant
For Each cell In f_rng
    Select Case InStr(f_str, cell.Value)
        Case 0
            cnt = WorksheetFunction.CountIf(f_rng, cell.Value)
            If cnt = 1 Then
                f_i = f_i + 1
                If f_i = rnk Then
                    ans = cell.Value
                    Exit For
                End If
            End If
    End Select
Next cell
Unique = ans
End Function

 

[dennisli]

thats' wonderful. thanks.

 

[DonkeyOte]

I missed one line in mine... so just in case you decided to use it...

Function Unique(f_rng, rnk As Long)
Dim cell As Range
Dim f_str As String
Dim f_i As Integer
Dim ans As Variant
For Each cell In f_rng
    Select Case InStr(f_str, cell.Value)
        Case 0
            cnt = WorksheetFunction.CountIf(f_rng, cell.Value)
            If cnt = 1 Then
                f_i = f_i + 1
                <b>f_str = f_str & "," & cell.Value</b>
                If f_i = rnk Then
                    ans = cell.Value
                    Exit For
                End If
            End If
    End Select
Next cell
Unique = ans
End Function

To reiterate though iliace's is the more elegant (by far).

 

[Fazza]

This may be of interest. For example put it into your personal macro workbook and assign short cut key CTRL-SHIFT-U (for Unique).

Just a quick way to use the built in advanced filter of unique items to put the unique items in the first row one column clear of the last entry in the column. To use: select the data to be filtered, including header, and then execute the code. I use it all the time in my work. BTW, not everyone knows this can be used on more than one field but this is also standard functionality.

HTH, Fazza

Sub UniqueItems()
  On Error GoTo ErrorHandler
  With Selection
    .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, Cells.Find(What:="*", After:=Cells(1, 1), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2), Unique:=True
  End With
ResumeHere:
  Exit Sub
 
ErrorHandler:
  MsgBox prompt:="Something went wrong !!", Buttons:=vbCritical, Title:="Error ..."
  GoTo ResumeHere
End Sub

 

[jindon]

Select B1:B100
Enter =dennis(A1:A100)
Confirm with Ctrl + Shift + Enter

Function dennis(rng As Range) As Variant
Dim a, e
a = rng.Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each e In a
        If (Not IsEmpty(e)) * (Not .exists(e)) Then .add e, Nothing
    Next
    dennis = Application.Transpose(.keys)
End With
End Function

 

[PaddyD]

for a formula approach:

=INDEX($A$10:$A$100,SMALL(IF(FREQUENCY(IF($A$10:$A$100<>"",MATCH("~"&$A$10:$A$100,$A$10:$A$100&"",0)),ROW($A$10:$A$100)-ROW($A$10)+1),ROW($A$10:$A$100)-ROW($A$10)+1),ROWS($A$10:A10)))

...entered with control + shift + enter, not just enter. also, don't forget the:

filter | advanced filter - copy to another location & unique records only

...option.