Unique Entries with a Twist

  • Thread starter Thread starter frank
  • Start date Start date
F

frank

I've got the typical "how can I get my unique entries" problem but this
one has a little bit more to it so I can't just use the method found on
http://www.contextures.com/xladvfilter01.html

I have a list of things like this (each line is a column- ie more than
one value can be in each cell):

Apples Oranges Grapes Grapes
Oranges Apples
Pears
Apples Pears Grapes

And I want the unique list of
Apples
Oranges
Grapes
Pears

Now if I just use the unique values formula from Contextures, all I get
is a list of
Apples Oranges Grapes Grapes
Oranges Apples
Pears
Apples Pears Grapes

Which makes sense because those are all "unique"- but it's not what I'm
looking for. Anyone have a hint or formula to send me in the right
direction?

-frank
 
Frank,

You may have to use a macro: select your cells with the multiple
values, then run the macro below. This assumes that you have only
blank cells below your selected cells to list the unique values.

HTH,
Bernie
MS Excel MVP

Sub CreateListOfUniqueValues()
Dim i As Integer
Dim j As Integer
Dim myVals() As String
Dim myCell As Range
Dim myCelVal As Variant

ReDim myVals(1 To 1)
myVals(1) = "Unique Values"
For Each myCell In Selection
myCelVal = Split(myCell.Value, " ")
For i = 0 To UBound(myCelVal)
For j = 1 To UBound(myVals)
If myCelVal(i) = myVals(j) Then GoTo AlreadyFound
Next j
ReDim Preserve myVals(1 To UBound(myVals) + 1)
myVals(UBound(myVals)) = myCelVal(i)
AlreadyFound:
Next i

Next myCell

For i = 1 To UBound(myVals)
Selection.Cells(Selection.Cells.Count + 1 + i) = myVals(i)
Next i

End Sub
 
Try the "Text to Column" feature under Data

this will place the items in seperate cells which you can sum.
 
...
...
I have a list of things like this (each line is a column- ie more than
one value can be in each cell):

Apples Oranges Grapes Grapes
Oranges Apples
Pears
Apples Pears Grapes

And I want the unique list of
Apples
Oranges
Grapes
Pears
Click to expand...
...

Difficult with built-in functionality unless you use several more cells than the
number of results you need. Much easier with add-ins. If you download and
install Laurent Longre's MOREFUNC.XLL add-in, available from

http://longre.free.fr/english/

then it provides functions named MCONCAT and EVAL which would allow you to do
this as follows. With the source data in a range named List, and the topmost
result cell E1, try these formulas.

E1:
=LEFT(T(List),FIND(" ",T(List))-1)

E2: [array formula]
=INDEX(EVAL("{"""&SUBSTITUTE(TRIM(MCONCAT(List&" "))," ",""",""")&"""}"),
MATCH(0,COUNTIF(E$1:E1,EVAL("{"""&SUBSTITUTE(TRIM(MCONCAT(List&" "))," ",
""",""")&"""}")),0))

Select E2 and fill down as far as needed.
 
You may have to use a macro: select your cells with the multiple
values, then run the macro below. This assumes that you have only
blank cells below your selected cells to list the unique values. ...
Sub CreateListOfUniqueValues() ...
myCelVal = Split(myCell.Value, " ") ...
End Sub
Click to expand...

OP didn't mention Excel version, and Split is only available in XL2K and higher.
Also, a udf would be more flexible, and this problem is ideal for associative
arrays. If the OP has a recent version of Windows or Internet Explorer 5.0 or
higher (so has Windows Script Host installed), the following should work. If the
list is long, this should be as fast at recalculating as possible.


Function DistinctSubstrings(sc As Variant, Optional sep As String) As Variant
Dim a As Object, s As Variant, t As String
Dim p As Long, q As Long, scr As Boolean, dsep As Boolean

If Not (TypeOf sc Is Range Or IsArray(sc)) Then
DistinctSubstrings = CVErr(xlErrRef)
Exit Function
End If

If sep = "" Then
dsep = True
sep = " "
End If

scr = (TypeOf sc Is Range)

Set a = CreateObject("Scripting.Dictionary")
a.CompareMode = 1

For Each s In sc

If scr Then s = s.Value

If dsep Then s = Application.WorksheetFunction.Trim(s)

q = 1
p = InStr(q, s, sep)

Do While p > 0
t = Mid(s, q, p - q)
If Not a.Exists(t) Then a.Add t, 1
q = p + Len(sep)
p = InStr(q, s, sep)
Loop

t = Mid(s, q)
If Not a.Exists(t) Then a.Add t, 1

Next s

DistinctSubstrings = Application.WorksheetFunction.Transpose(a.Keys)
Set a = Nothing

End Function
 
Thanks for all the help, all. I haven't figured out if I'm going to try
and implement the macro solution (I've never played around with them
before- but this could be a good learning experience) or one of the
others as soon as I get a school project out of the way :D

thanks again,
frank
 
Back
Top