Count occurances in a group of data

  • Thread starter Thread starter Shhhh
  • Start date Start date
S

Shhhh

Hello,

my problem is on a much larger scale, but here is a simplified example
of what I'm looking for

Column B-K have different statistical categories. Row 1-5 have
different names under each column... for example:

B C D
name 1 name 6 name 8
name 2 name 7 name 7
name 3 name 2 name 9
name 4 name 1 name 1
name 5 name 4 name 2...

etc.

How can I tell excel to go through all 10 columns and all 5 rows. and
pull out every unique name, and tell me how many times each name
appears?

So the analysis I'm looking for would return results basically like
this...

name 1 (appears 3 times)
name 2 (appears 3 times)
name 3 (appears 1 time)
name 4 (appears 2 times)
name 5 (appears 1 time)
name 6 (appears 1 time)
name 7 (appears 2 times)
name 8 (appears 1 time)
name 9 (appears 1 time)

Can what I'm asking for be done??

Thank you all!
 
Hello,

my problem is on a much larger scale, but here is a simplified example
of what I'm looking for

Column B-K have different statistical categories. Row 1-5 have
different names under each column... for example:

B C D
name 1 name 6 name 8
name 2 name 7 name 7
name 3 name 2 name 9
name 4 name 1 name 1
name 5 name 4 name 2...

etc.

How can I tell excel to go through all 10 columns and all 5 rows. and
pull out every unique name, and tell me how many times each name
appears?

So the analysis I'm looking for would return results basically like
this...

name 1 (appears 3 times)
name 2 (appears 3 times)
name 3 (appears 1 time)
name 4 (appears 2 times)
name 5 (appears 1 time)
name 6 (appears 1 time)
name 7 (appears 2 times)
name 8 (appears 1 time)
name 9 (appears 1 time)

Can what I'm asking for be done??

Thank you all!
Click to expand...

Here's a VBA macro that will return the list of unique entries in "Selection"
along with the count of each entry.

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

To use this Macro (Sub), first select the range of cells you wish to analyze.
Then <alt-F8> opens the macro dialog box. Select the macro by name, and <RUN>.

===================================
Option Explicit
Option Compare Text
Sub UniqueList()
Dim rDest As Range
Dim rg As Range

'There are many ways to define the
' range to process.
Set rg = Selection

'There are also many ways to define
' the output range
Set rDest = Range(InputBox("Range for Results: ")).Resize(1, 1)

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, CStr(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

'sort by Count highest to lowest
BubbleSortX sRes, 1, False

'Sort words alphabetically A-Z
BubbleSortX sRes, 0, True

For i = LBound(sRes, 2) To UBound(sRes, 2)
rDest(i, 1).Value = sRes(0, i)
rDest(i, 2).Value = sRes(1, i)
Next i

End Sub
'--------------------------------------------------------------
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
 
Here's a VBA macro that will return the list of unique entries in "Selection"
along with the count of each entry.

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

To use this Macro (Sub), first select the range of cells you wish to analyze.
Then <alt-F8> opens the macro dialog box. Select the macro by name, and <RUN>.

===================================
Option Explicit
Option Compare Text
Sub UniqueList()
Dim rDest As Range
Dim rg As Range

'There are many ways to define the
' range to process.
Set rg = Selection

'There are also many ways to define
'  the output range
Set rDest = Range(InputBox("Range for Results: ")).Resize(1, 1)

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, CStr(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

'sort by Count highest to lowest
BubbleSortX sRes, 1, False

'Sort words alphabetically A-Z
BubbleSortX sRes, 0, True

For i = LBound(sRes, 2) To UBound(sRes, 2)
    rDest(i, 1).Value = sRes(0, i)
    rDest(i, 2).Value = sRes(1, i)
Next i

End Sub
'--------------------------------------------------------------
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
Click to expand...

Works like a charm, perfect. Thank you!!
 
Back
Top