UniqueItems Array

[Darren]

I found the following code on this site http://www.j-walk.com/ss/excel/index.htm,
and it returns a list of unique items in a given range by entering an
array in the worksheet eg
{=uniqueitems(A1:A100,FALSE)}

Problem is that I do not know how many unique items are going to be
returned from the list so if I enter the array formula in B1:B50 and
there are 25 unique items then the formula returns #N/A in the other
25 cells.

Is there any way to change either the VBA code below or the array
formula so that #N/A is not returned.

Many thanks for any help provided

D

CODE STARTS *******************

Option Base 1
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number
' of unique elements
' If Count = False, the function returns a variant array of unique
' elements


Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean


' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True


' Counter for number of unique elements
NumUnique = 0


' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False


' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i


AddItem:
' If not in list, add the item to unique list
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If


Next Element


' Assign a value to the function
If Count Then UniqueItems = NumUnique Else _
UniqueItems = Application.Transpose(Unique)

End Function

CODE ENDS *********************

 

[Tom Ogilvy]

Option Base 1
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number
' of unique elements
' If Count = False, the function returns a variant array of unique
' elements


Dim Unique() As Variant ' array that holds the unique items
Dim u() As Variant
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
Dim r As Range
Set r = Application.Caller


' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True


' Counter for number of unique elements
NumUnique = 0


' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False


' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i


AddItem:
' If not in list, add the item to unique list
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If


Next Element


' Assign a value to the function
If Count Then
UniqueItems = NumUnique
Else
If NumUnique > r.Count Then
ReDim Preserve Unique(1 To r.Count)
Unique(UBound(Unique)) = (NumUnique - r.Count) + 1 & " more"
UniqueItems = Application.Transpose(Unique)
ElseIf NumUnique < r.Count Then
ReDim Preserve Unique(1 To r.Count)
For i = NumUnique + 1 To r.Count
Unique(i) = ""
Next
UniqueItems = Application.Transpose(Unique)
Else
UniqueItems = Application.Transpose(Unique)
End If
End If
End Function

 

[Darren]

Hi Tom,

Fantastic......... many thanks

Darren

Option Base 1
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number
' of unique elements
' If Count = False, the function returns a variant array of unique
' elements

Dim Unique() As Variant ' array that holds the unique items
Dim u() As Variant
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
Dim r As Range
Set r = Application.Caller

' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True

' Counter for number of unique elements
NumUnique = 0

' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False

' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i

AddItem:
' If not in list, add the item to unique list
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If

Next Element

' Assign a value to the function
If Count Then
UniqueItems = NumUnique
Else
If NumUnique > r.Count Then
ReDim Preserve Unique(1 To r.Count)
Unique(UBound(Unique)) = (NumUnique - r.Count) + 1 & " more"
UniqueItems = Application.Transpose(Unique)
ElseIf NumUnique < r.Count Then
ReDim Preserve Unique(1 To r.Count)
For i = NumUnique + 1 To r.Count
Unique(i) = ""
Next
UniqueItems = Application.Transpose(Unique)
Else
UniqueItems = Application.Transpose(Unique)
End If
End If
End Function

--
Regards,
Tom Ogilvy



















- Show quoted text -