Excel-VBA: Count occurrencies of a different strings and list them - vba

Question

Today I have the following problem: I have 2 columns of x rows (doesn't matter how many) in Excel with a string in each one, like this
A B
Apple Potato
Banana Potato
Apple Potato
Orange Apple
Each string can appear in both column.
I need to obtain the following results:
Fruit Occurrencies
Apple 3
Banana 1
Potato 3
Orange 1
Now, I know for sure that there's a way much faster than what I could think of and I'd appreciate any help you can give.
My solution would consist in storing one by one the strings in an array checking each time if they are already contained in the slots before the current one and, if not, counting its occurrencies too. For example after having stored all the strings in an array (which I will now call Fruit()):
Dim Str() As Variant
Dim Flag As Boolean
For i = LBound(Fruit)+1 to Ubound(Fruit)
Flag = True
For j = i to LBound(Fruit)
If Fruit(i) = Fruit(j) Then
Flag = False
Exit For
End If
Next
If Flag = True Then
Str(k,0) = Fruit(i)
For y = LBound(Fruit) to UBound(Fruit)
if Str(k,0) = Fruit(y) Then Str(k,1) = Str(k,1)+1
Next
k = k+1
End If
Next
This is totally crazy and I know there's an easier solution... I just can't find it.

Answer 1

You can use the dictionary object, it looks pretty straightforward to me
Sub fruitsCount()
Dim sourceRange As Range
Dim sourceMem As Object
Dim curRow as integer
'CHANGE TO WHATEVER SHEET NAME YOUR ARE USING
With Worksheets("SOURCE_SHEET")
Set sourceRange = .Range("A1:B" & .Range("A" & .Rows.count).End(xlUp).row)
End with
Set sourceMem = CreateObject("Scripting.dictionary")
For Each cell In sourceRange
On Error GoTo ERREUR
sourceMem.Add cell.Value, 1
On Error GoTo 0
Next
curRow = 2
'CHANGE TO WHATEVER SHEET NAME YOUR ARE USING
With Worksheets("DESTINATION_SHEET")
.Range("A1").Value = "Fruit"
.Range("B1").Value = "Occurencies"
For Each k In sourceMem.Keys
.Range("A" & curRow).Value = k
.Range("B" & curRow).Value = sourceMem(k)
curRow = curRow + 1
Next k
End With
Set sourceMem = Nothing
Exit Sub
ERREUR:
sourceMem(cell.Value) = sourceMem(cell.Value) + 1
Resume Next
End Sub
Edit: the logic behind the code is actually fairly simple, and relies on the dictionary object which allows to garner (key, value) pairs. Here the keys will be the fruit names, and the values the number of occurences for each fruit. The distinctive feature of the dictionary object the code relies on is that it won't allow duplicate keys - any time you try and add a key that already exists in the dictionary, a runtime error will be issued.
So the code just scans through each and every cell of your source range and it tries to add its value as a key to the dictionary:
if the operation succeeds, then this is the first occurence for that fruit in the source range - it is added as a key to the dictionary, and its paired value is set to 1
else, the fruit already exists as a key in the dictionary - and thus an error occurs when trying to add the fruit to the dictionary. The code then jumps to the ERREUR error hanlder to increment the value paired with that existing fruit key in the dictionary, and resume normal execution from there
Hopes that helps clarifying

Answer 2

Checking yours as a correct answer and +1 for help, but I wanted to share with the community the effort to make this work for an array too:
Private Function FilesCount(SourceRange As Range) As Variant
Dim SourceMem As Object
Dim Occurrencies() As Variant
Dim OneCell As Range
Dim i As Integer
Set SourceMem = CreateObject("Scripting.dictionary")
For Each OneCell In SourceRange
On Error GoTo Hell
SourceMem.Add OneCell.Value, 1
On Error GoTo 0
Next
ReDim Occurrencies(SourceMem.Count - 1, 1)
For i = 0 To SourceMem.Count - 1
Occurrencies(i, 0) = SourceMem.Keys()(i)
Occurrencies(i, 1) = SourceMem.Items()(i)
Next i
Set SourceMem = Nothing
FilesCount = Occurrencies
Exit Function
Hell:
SourceMem(OneCell.Value) = SourceMem(OneCell.Value) + 1
Resume Next
End Function
It returns an (n x 2) array, in which there are n names and their occurrence in the selected range