CODEWITHSUNDEEP
excelexcel-2010vba
hammythepig
hammythepig

Reputation: 957

Count the occurences of each unique string in a range

I have a large range of values, with some blanks in between, and I was wondering how I could find the of total all the different values, each with their own total in that range.

For example, I have (in the range A1:D5): 

| Low | Low | --- | Low |  
| Low | High| --- | Low |  
| --- | --- | --- | --- |  
| Pie | --- | Low | High|  
| --- | --- | Low | --- |

I would like the program to spit out:
(in a range or a msgbox or anything, the user needs to write down the numbers) 

High: 2  
Low: 7 
Pie: 1

What I've tried:
I tried using the CountIF function, but have been having problems figuring it out properly.
I have well over 800 lines to test for, so I'd like to avoid iterating through every line in a simple for loop.

Bonus points:
(I'd be happy with an answer to just the above, but if someone could figure this out too it would be much appreciated)
There are some cell values which compose of muliple instances of a word or even muliple words.
For example, a few cells contain

Low
Low

separated only by a carriage return. There is even one cell in this current month that contains

Low
Low
High
Low
Low

I would also like to count each occurrence inside the cells, so the above cell would give the output:

High: 1
Low: 4

Upvotes: 0

Views: 1141

Answers (2)

Aaron Thomas
Aaron Thomas

Reputation: 5281

Try the .find method. Go to your VBA help, look up the range.find method for some more info - it also provides some code that you should be able to modify easily.
I'd suggest using a counter for each value that updates each time you have a find. For example:

Dim Low_count As Long  
Low_count = 0  
With Worksheets(1).Range("a1:a500")  
 Set c = .Find("Low", LookIn:=xlValues)  
 If Not c Is Nothing Then  
  firstAddress = c.Address
  Do
   Low_count = Low_count + 1
   Set c = .FindNext(c)
  Loop While Not c Is Nothing And c.Address <> firstAddress
 End If
End With

Upvotes: 1

tigeravatar
tigeravatar

Reputation: 26670

Give this a try:

Sub tgr()

    Dim cllUnq As Collection
    Dim rngCheck As Range
    Dim CheckCell As Range
    Dim arrUnq(1 To 65000) As String
    Dim arrCount(1 To 65000) As Long
    Dim varWord As Variant
    Dim MatchIndex As Long
    Dim lUnqCount As Long

    On Error Resume Next
    Set rngCheck = Application.InputBox("Select the cells containing strings to be counted", "Select Range", Selection.Address, Type:=8)
    On Error GoTo 0
    If rngCheck Is Nothing Then Exit Sub    'Pressed cancel

    Set cllUnq = New Collection

    For Each CheckCell In rngCheck.Cells
        For Each varWord In Split(CheckCell.Text, Chr(10))
            If Len(Trim(varWord)) > 0 Then
                On Error Resume Next
                cllUnq.Add varWord, varWord
                On Error GoTo 0
                If cllUnq.Count > lUnqCount Then
                    lUnqCount = cllUnq.Count
                    arrUnq(lUnqCount) = CStr(varWord)
                    arrCount(lUnqCount) = 1
                Else
                    MatchIndex = WorksheetFunction.Match(CStr(varWord), arrUnq, 0)
                    arrCount(MatchIndex) = arrCount(MatchIndex) + 1
                End If
            End If
        Next varWord
    Next CheckCell

    If lUnqCount > 0 Then
        Sheets.Add After:=Sheets(Sheets.Count)
        With Range("A1:B1")
            .Value = Array("Word", "Count")
            .Font.Bold = True
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
        End With
        Range("A2").Resize(lUnqCount).Value = Application.Transpose(arrUnq)
        Range("B2").Resize(lUnqCount).Value = Application.Transpose(arrCount)
    End If

    Set cllUnq = Nothing
    Set rngCheck = Nothing
    Set CheckCell = Nothing
    Erase arrUnq
    Erase arrCount

End Sub

Upvotes: 3

Related Questions