
Option Explicit
Sub abc()
Dim a, i, j, d
a = [a1].Resize(ActiveSheet.UsedRange.Rows.Count, 12).Value
ReDim b(1 To UBound(a), 1 To 1)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
For j = 1 To UBound(a, 2)
If Len(a(i, j)) Then d(a(i, j)) = d(a(i, j)) + 1
Next
If d.Count > 0 Then b(i, 1) = Join(d.keys, ",") & "->" & Join(d.items, ",")
d.RemoveAll
Next
[m1].Resize(UBound(b)) = b
End Sub