Does anyone have any suggestions on how to determine the number of types?
For example
Under A column, there is a list of name, and under B column, there is a list
of fruits.
John Apple
Mary Orange
Ann Banana
Michelle Apple
Peter Mango
Smith Banana
Sam Banana
I would like to know a list of fruits, and shows them in C column without
duplication.
Apple
Banana
Mango
Orange
Does anyone have any suggestions?
Thank you very much for any suggestions
Eric
Here is a UDF that will return a horizontal array of unique values along with
their counts. As written, it sorts first by count, giving the most frequent
first, and then alphabetically.
You can change the sorting order (see comments within the UDF).
To enter the UDF, <alt-F11> opens the VBEditor. Ensure your project is
highlighted in the Project Explorer window, then Insert/Module and paste the
code below into the window that opens.
To use this in your workbook, enter a function of the form:
Unique Fruits:
=INDEX(UniqueCount(Fruit),1,ROWS($1:1))
and in an adjacent cell for the Count of each:
=INDEX(UniqueCount(Fruit),2,ROWS($1:1))
Then fill down as far as required.
If you have a very long list, this method -- especially the sorting part -- may
be unduly slow for you. If so, we could make some changes there.
==============================================
Option Explicit
Option Compare Text
Function UniqueCount(rg As Range)
'Returns a horizontal two dimensional
' array of unique words and count
Dim cWordList As Collection
Dim Str As String
Dim sRes() As Variant
Dim I As Long, J As Long
Dim c As Range
'get list of unique words
Set cWordList = New Collection
On Error Resume Next
For Each c In rg
cWordList.Add c.Value, c.Value
Next c
On Error GoTo 0
ReDim sRes(0 To 1, 1 To cWordList.Count)
For I = 1 To cWordList.Count
sRes(0, I) = cWordList(I)
Next I
'get word count for each word
For I = 1 To UBound(sRes, 2)
sRes(1, I) = Application.WorksheetFunction.CountIf(rg, sRes(0, I))
Next I
'Reverse sorting order if you want the words alphabetically
'without respect to the counts
'Sort words alphabetically A-Z
BubbleSort sRes, 0, True
'then sort by Count highest to lowest
BubbleSort sRes, 1, False
UniqueCount = sRes
End Function
'--------------------------------------------------------------
Private Sub BubbleSort(TempArray As Variant, d As Long, _
bSortDirection As Boolean)
'bSortDirection = True means sort ascending
'bSortDirection = False means sort descending
Dim Temp1 As Variant, Temp2
Dim I As Long
Dim NoExchanges As Boolean
Dim Exchange As Boolean
' Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array.
For I = 1 To UBound(TempArray, 2) - 1
' If the element is greater/less than the element
' following it, exchange the two elements.
Exchange = TempArray(d, I) < TempArray(d, I + 1)
If bSortDirection = True Then Exchange = _
TempArray(d, I) > TempArray(d, I + 1)
If Exchange Then
NoExchanges = False
Temp1 = TempArray(0, I)
Temp2 = TempArray(1, I)
TempArray(0, I) = TempArray(0, I + 1)
TempArray(1, I) = TempArray(1, I + 1)
TempArray(0, I + 1) = Temp1
TempArray(1, I + 1) = Temp2
End If
Next I
Loop While Not (NoExchanges)
End Sub
=======================================
--ron
