Sulprobil
Search…
Cfreq
If you need to list all string entries for some given combinations, separated by "," then Cfreq might help. Example:
Another example:
1
Function Cfreq(ParamArray v()) As Variant
2
'Cfreq lists how often each value combination
3
'in paramarray appears and concatenates the last
4
'column's entries, separated by ",". Example:
5
' A B
6
' 1 Smith Adam
7
' 2 Myer Ben
8
' 3 Smith Ben
9
' 4 Smith Adam
10
' 5 Myer Ben
11
'Now select C1:E3 and array-enter
12
'=Cfreq(A1:A5,B1:B5) and you will get
13
' C D
14
' 1 Smith Adam,Ben
15
' 2 Myer Ben
16
'Reverse("moc.liborplus.www") V0.3 15-Oct-2009
17
Dim obj As Object, objcat As Object
18
Dim vR As Variant
19
Dim i As Long, j As Long, k As Long, lvdim As Long
20
Dim s As String, sC As String
21
​
22
With Application.WorksheetFunction
23
sC = "|"
24
Set obj = CreateObject("Scripting.Dictionary")
25
Set objcat = CreateObject("Scripting.Dictionary")
26
k = 0
27
v(0) = .Transpose(.Transpose(v(0)))
28
If UBound(v) < 1 Then
29
Cfreq = CVErr(xlErrValue)
30
Exit Function
31
End If
32
lvdim = UBound(v(0))
33
On Error GoTo 0
34
ReDim vR(0 To UBound(v), 1 To lvdim)
35
For i = 1 To lvdim
36
s = v(0)(i, 1)
37
For j = 1 To UBound(v) - 1
38
v(j) = .Transpose(.Transpose(v(j)))
39
s = s & sC & v(j)(i, 1)
40
Next j
41
If obj.Item(s) > 0 Then
42
If objcat.Item(s & sC & v(UBound(v))(i, 1)) = 0 Then
43
vR(UBound(v), obj.Item(s)) = vR(UBound(v), _
44
obj.Item(s)) & "," & _
45
v(UBound(v))(i, 1)
46
objcat.Item(s & sC & v(UBound(v))(i, 1)) = 1
47
End If
48
Else
49
k = k + 1
50
obj.Item(s) = k
51
For j = 0 To UBound(v) - 1
52
vR(j, k) = v(j)(i, 1)
53
Next j
54
vR(UBound(v), k) = v(UBound(v))(i, 1) & ""
55
objcat.Item(s & sC & v(UBound(v))(i, 1)) = 1
56
End If
57
Next i
58
If k > 0 Then ReDim Preserve vR(0 To UBound(v), 1 To k)
59
Set obj = Nothing
60
Set objcat = Nothing
61
Cfreq = .Transpose(vR)
62
End With
63
End Function
Copied!
Use a Sub if you have to deal with strings of more than 256 characters:
1
Sub CfreqSub(rOutput As Range, rInputClasses As Range, _
2
rInputProperties As Range, Optional sDel As String = ",")
3
'CfreqSub lists each value combination in rInputClasses and
4
'concatenates their properties given in rInputProperties,
5
'separated by ",". Output starts in [upper left cell of] rOutput.
6
'Example:
7
' A B
8
' 1 Smith Adam
9
' 2 Myer Ben
10
' 3 Smith Ben
11
' 4 Smith Adam
12
' 5 Myer Ben
13
'Now call CfreqSub(C1,A1:A5,B1:B5) and you will get
14
' C D
15
' 1 Smith Adam,Ben
16
' 2 Myer Ben
17
'PLEASE NOTE: This sub was created to overcome Cfreq's
18
'limitation of max 256 characters in input and output
19
'strings.
20
'Reverse("moc.liborplus.www") V0.20 09-Oct-2011
21
Dim obj As Object, objcat As Object
22
Dim vR As Variant
23
Dim i As Long, j As Long, k As Long, lvdim As Long
24
Dim s As String, sC As String
25
Dim state As SystemState 'See http://sulprobil.com/html/systemstate.html
26
​
27
Set state = New SystemState 'See http://sulprobil.com/html/systemstate.html
28
​
29
With Application.WorksheetFunction
30
sC = "|"
31
Set obj = CreateObject("Scripting.Dictionary")
32
Set objcat = CreateObject("Scripting.Dictionary")
33
lvdim = rInputClasses.Rows.Count
34
If lvdim <> rInputProperties.Count Then
35
Cfreq = CVErr(xlErrValue)
36
Exit Sub
37
End If
38
ReDim vR(1 To lvdim, 0 To rInputClasses.Columns.Count)
39
For i = 1 To lvdim
40
s = rInputClasses.Cells(i, 1)
41
For j = 2 To rInputClasses.Columns.Count
42
s = s & sC & rInputClasses.Cells(i, j)
43
Next j
44
If obj.Item(s) > 0 Then
45
If objcat.Item(s & sC & rInputProperties(i)) = 0 Then
46
vR(obj.Item(s), rInputClasses.Columns.Count) = vR(obj.Item(s), _
47
rInputClasses.Columns.Count) & sDel & rInputProperties(i)
48
objcat.Item(s & sC & rInputProperties(i)) = 1
49
End If
50
Else
51
k = k + 1
52
obj.Item(s) = k
53
For j = 1 To rInputClasses.Columns.Count
54
vR(k, j - 1) = rInputClasses.Cells(i, j)
55
Next j
56
vR(k, rInputClasses.Columns.Count) = rInputProperties(i) & ""
57
objcat.Item(s & sC & rInputProperties(i)) = 1
58
End If
59
Next i
60
Set obj = Nothing
61
Set objcat = Nothing
62
​
63
Range(rOutput.Cells(1, 1), rOutput.Cells(k, rInputClasses.Columns.Count + 1)) = vR
64
​
65
End With
66
End Sub
Copied!
Last modified 1yr ago
Copy link