Cfreq

If you need to list all string entries for some given combinations, separated by "," then Cfreq might help. Example:
Another example:
Please read my Disclaimer.
Function Cfreq(ParamArray v()) As Variant
'Cfreq lists how often each value combination
'in paramarray appears and concatenates the last
'column's entries, separated by ",". Example:
'    A     B
' 1 Smith Adam
' 2 Myer  Ben
' 3 Smith Ben
' 4 Smith Adam
' 5 Myer  Ben
'Now select C1:E3 and array-enter
'=Cfreq(A1:A5,B1:B5) and you will get
'     C     D
' 1 Smith  Adam,Ben
' 2 Myer   Ben
'Reverse("moc.liborplus.www") V0.3 15-Oct-2009
Dim obj As Object, objcat As Object
Dim vR As Variant
Dim i As Long, j As Long, k As Long, lvdim As Long
Dim s As String, sC As String
​
With Application.WorksheetFunction
sC = "|"
Set obj = CreateObject("Scripting.Dictionary")
Set objcat = CreateObject("Scripting.Dictionary")
k = 0
v(0) = .Transpose(.Transpose(v(0)))
If UBound(v) < 1 Then
    Cfreq = CVErr(xlErrValue)
    Exit Function
End If
lvdim = UBound(v(0))
On Error GoTo 0
ReDim vR(0 To UBound(v), 1 To lvdim)
For i = 1 To lvdim
    s = v(0)(i, 1)
    For j = 1 To UBound(v) - 1
        v(j) = .Transpose(.Transpose(v(j)))
        s = s & sC & v(j)(i, 1)
    Next j
    If obj.Item(s) > 0 Then
        If objcat.Item(s & sC & v(UBound(v))(i, 1)) = 0 Then
            vR(UBound(v), obj.Item(s)) = vR(UBound(v), _
                                         obj.Item(s)) & "," & _
                                         v(UBound(v))(i, 1)
            objcat.Item(s & sC & v(UBound(v))(i, 1)) = 1
        End If
    Else
        k = k + 1
        obj.Item(s) = k
        For j = 0 To UBound(v) - 1
            vR(j, k) = v(j)(i, 1)
        Next j
        vR(UBound(v), k) = v(UBound(v))(i, 1) & ""
        objcat.Item(s & sC & v(UBound(v))(i, 1)) = 1
    End If
Next i
If k > 0 Then ReDim Preserve vR(0 To UBound(v), 1 To k)
Set obj = Nothing
Set objcat = Nothing
Cfreq = .Transpose(vR)
End With
End Function
Use a Sub if you have to deal with strings of more than 256 characters:
Sub CfreqSub(rOutput As Range, rInputClasses As Range, _
             rInputProperties As Range, Optional sDel As String = ",")
'CfreqSub lists each value combination in rInputClasses and
'concatenates their properties given in rInputProperties,
'separated by ",". Output starts in [upper left cell of] rOutput.
'Example:
'    A     B
' 1 Smith Adam
' 2 Myer  Ben
' 3 Smith Ben
' 4 Smith Adam
' 5 Myer  Ben
'Now call CfreqSub(C1,A1:A5,B1:B5) and you will get
'     C     D
' 1 Smith  Adam,Ben
' 2 Myer   Ben
'PLEASE NOTE: This sub was created to overcome Cfreq's
'limitation of max 256 characters in input and output
'strings.
'Reverse("moc.liborplus.www") V0.20 09-Oct-2011
Dim obj As Object, objcat As Object
Dim vR As Variant
Dim i As Long, j As Long, k As Long, lvdim As Long
Dim s As String, sC As String
Dim state As SystemState 'See http://sulprobil.com/html/systemstate.html
​
Set state = New SystemState 'See http://sulprobil.com/html/systemstate.html
​
With Application.WorksheetFunction
sC = "|"
Set obj = CreateObject("Scripting.Dictionary")
Set objcat = CreateObject("Scripting.Dictionary")
lvdim = rInputClasses.Rows.Count
If lvdim <> rInputProperties.Count Then
    Cfreq = CVErr(xlErrValue)
    Exit Sub
End If
ReDim vR(1 To lvdim, 0 To rInputClasses.Columns.Count)
For i = 1 To lvdim
    s = rInputClasses.Cells(i, 1)
    For j = 2 To rInputClasses.Columns.Count
        s = s & sC & rInputClasses.Cells(i, j)
    Next j
    If obj.Item(s) > 0 Then
        If objcat.Item(s & sC & rInputProperties(i)) = 0 Then
            vR(obj.Item(s), rInputClasses.Columns.Count) = vR(obj.Item(s), _
                rInputClasses.Columns.Count) & sDel & rInputProperties(i)
            objcat.Item(s & sC & rInputProperties(i)) = 1
        End If
    Else
        k = k + 1
        obj.Item(s) = k
        For j = 1 To rInputClasses.Columns.Count
            vR(k, j - 1) = rInputClasses.Cells(i, j)
        Next j
        vR(k, rInputClasses.Columns.Count) = rInputProperties(i) & ""
        objcat.Item(s & sC & rInputProperties(i)) = 1
    End If
Next i
Set obj = Nothing
Set objcat = Nothing
​
Range(rOutput.Cells(1, 1), rOutput.Cells(k, rInputClasses.Columns.Count + 1)) = vR
​
End With
End Sub

Afreq

Count String Combinations

Last modified 2yr ago

Copy link