Hello,
I have two ranges of data in two ranges of cells. Basically H4
downwards, and G4 downwards.
The cells typically consists of a list of names seperate by comma's.
So you might have:
A. Smith, B. Jones, G. Smith
G. Smith
A. Jones, B Jones
B. Jones
I would like to ultimately have (on another sheet) and list which
takes all the unique values and counts them. So it would look like
this:
A. Smith 1
B. Jones 3
G. Smith 2
A. Jones 1
Of course, it would also combine it with the same (type of) data from
column G, but hey, lets work on one column at a time!
I thought of concatonating all of the cells together, but that only
seems to work for 30 sells, so perhaps that is not the best way.
Can anyone point me in the right direction?
Thanks
So long as you don't have duplicate names within the same cell, that need to be
counted as separate occurrences, you should be able to modify this function to
do what you describe.
As written, the function returns a horizontal 2-dimensional array of unique
entries and their number of occurrences.
It is sorted from most frequent to least frequent.
If you reverse the order of the sorting routines within the function, it will
sort alphabetically.
And if you eliminate the sorting routines, it will output in the order entered.
If you want a vertical array, merely nest the UDF within the TRANSPOSE
function:
e.g.: =TRANSPOSE(UniqueCount(G4:G100,K4:K75))
I have modified it already to allow for two separate ranges.
You can enter it as an array formula:
e.g. if you have 100 unique entries, enter the formula in, for example, A1.
Then select A1:B100 and confirm by holding down <ctrl><shift> while hitting
<enter>. Excel will fill the selected area with the formula, and also place
braces {...} around the formula, and you should see all of the individual
entries.
========================================
Option Explicit
Option Compare Text
Function UniqueCount(rg1 As Range, rg2 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
Dim aArr As Variant
Dim rg As Range
Set rg = Union(rg1, rg2)
'get list of unique words
Set cWordList = New Collection
On Error Resume Next
For Each c In rg
aArr = Split(c.Value, ",")
For I = 0 To UBound(aArr)
cWordList.Add Trim(aArr(I)), Trim(aArr(I))
Next I
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(rg1, "*" & sRes(0, I) & "*") _
+ Application.WorksheetFunction.CountIf(rg2, "*" & sRes(0, I) & "*")
Next I
'Reverse sorting order if you want the words alphabetically
'without respect to the counts
'Sort words alphabetically A-Z
BubbleSortX sRes, 0, True
'then sort by Count highest to lowest
BubbleSortX sRes, 1, False
UniqueCount = sRes
End Function
'--------------------------------------------------------------
Private Sub BubbleSortX(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
