Count number of occurrences of text in the same cell separated by ";"

[mfarhan]

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; 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]

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
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  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

[mfarhan]

Mr. Kenneth Hobs

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

Regards,,,