Sulprobil
Search…
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
Copy link