View Full Version : Count number of occurrences of text in the same cell separated by ";"

08-08-2016, 10:10 AM
Dear Experts,

This is my first post, so please excuse me if I break any rules. I am glad to be part of the Forum and appreciate any assistance.
I am facing a problem in the last step of my project where i need to give the compiled data.
I have the output so far as below in a single cell, for example in "C1":

Apple; Apple; Apple; Apple; Banana; Banana; Apple

I need it to become in the same cell "C1":

5 Apple; 2 Banana

I've multiple cells in the same column C which needs to become as above.

Example again:

Data in below form...

Apple; Apple; Apple; Apple; Apple; Apple; Apple; Apple; Apple; Apple; Apple; Apple

Banana; Apple; Grapes

Banana; Apple; Grapes; Banana; Apple; Grapes


Apple; Apple; Banana; Grapes; Grapes

Required Output as below:

12 Apple

1 Banana; 1 Apple; 1 Grapes

2 Banana; 2 Apple; 2 Grapes

1 Apple

2 Apple; 1 Banana; 2 Grapes

Kenneth Hobs
08-08-2016, 01:09 PM
Welcome to the forum! Your post is just fine.

When testing code, always test on a backup copy of the file or other backups as needed.

Play Main() with the sheet of interest selected or active.

Add the Microsoft Scripting Runtime in Tools > References as commented.

In a Module:

Sub Main()
Dim a() As String, aa() As Variant, b As Variant, c As Variant
Dim cr As Range, i As Long

For Each cr In Range("C1", Range("C" & Rows.Count).End(xlUp))
With cr
a() = Split(.Value, "; ")
aa() = sA1dtovA1d(a())
b = UniqueArrayByDict(aa)
c = b

For i = LBound(b) To UBound(b)
c(i) = CountSstrings(a(), CStr(b(i))) & " " & b(i)
Next i

.Value = Join(c, "; ")
End With
Next cr

'Debug.Print CountSstrings(a(), a(0)), UBound(aa) + 1
'Debug.Print UBound(b) + 1
End Sub

'Compare options: vbDataBaseCompare, vbTextCompare, and default vbBinaryCompare
Function CountSstrings(s() As String, ss As String, _
Optional mode As Integer = vbBinaryCompare) As Long
Dim i As Long, ii As Long
For ii = LBound(s) To UBound(s)
If ss = s(ii) Then i = i + 1
Next ii
CountSstrings = i
End Function

' Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
' Compare options: vbDataBaseCompare, vbTextCompare, and default vbBinaryCompare
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
'Dim dic As Object 'Late Binding method - Requires no Reference
'Set dic = CreateObject("Scripting.Dictionary") 'Late or Early Binding method
Dim dic As Dictionary 'Early Binding method
Set dic = New Dictionary 'Early Binding Method
Dim e As Variant
dic.CompareMode = compareMethod
For Each e In Array1d
If Not dic.Exists(e) Then dic.Add e, Nothing
Next e
UniqueArrayByDict = dic.Keys
End Function

Function RangeTo1dArray(aRange As Range) As Variant
Dim a() As Variant, c As Range, i As Long
ReDim a(0 To aRange.Cells.Count - 1)
i = i - 1
For Each c In aRange
i = i + 1
a(i) = c
Next c
RangeTo1dArray = a()
End Function

Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function

08-08-2016, 01:19 PM
Mr. Kenneth Hobs

Thank you so much, it worked 10000000000% as required. I have no words to thank you, in short, BIG THANKS!