Pfreq

Pfreq lists frequencies of input combinations:
Examples:
Please note that I do not recommend to use the Pfreq(Pfreq(...)) approach for more than some thousand rows: For 10,000 rows and two columns it takes more than 1 minute to calculate on my dual core computer!
If you need a sorted output you can take my UDF GSort.
Please read my Disclaimer.
1
Function Pfreq(ParamArray v()) As Variant
2
'Pfreq lists how often each value combination
3
'in paramarray appears. Example:
4
'    A     B
5
' 1 Smith Adam
6
' 2 Myer Ben
7
' 3 Smith Ben
8
' 4 Smith Adam
9
' 5 Myer Ben
10
'Now select C1:E3 and array-enter
11
'=Pfreq(A1:A5,B1:B5) and you will get
12
'    C   D    E
13
' 1 Smith  Adam  2
14
' 2 Myer   Ben   2
15
' 3 Smith  Ben   1
16
'Reverse("moc.liborplus.www") V0.4 15-Oct-2009
17
Dim obj 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
k = 0
26
v(0) = .Transpose(.Transpose(v(0)))
27
lvdim = UBound(v(0))
28
If lvdim > 100 Then lvdim = 100
29
On Error GoTo ErrHdl
30
ReDim vR(0 To UBound(v) + 1, 1 To lvdim)
31
For i = 1 To UBound(v(0))
32
    s = v(0)(i, 1)
33
    For j = 1 To UBound(v)
34
        v(j) = .Transpose(.Transpose(v(j)))
35
        s = s & sC & v(j)(i, 1)
36
    Next j
37
    If obj.Item(s) > 0 Then
38
        vR(UBound(v) + 1, obj.Item(s)) = vR(UBound(v) + 1, obj.Item(s)) + 1
39
    Else
40
        k = k + 1
41
        obj.Item(s) = k
42
        For j = 0 To UBound(v)
43
            vR(j, k) = v(j)(i, 1)
44
        Next j
45
        vR(UBound(v) + 1, k) = 1
46
    End If
47
Next i
48
If k > 0 Then ReDim Preserve vR(0 To UBound(v) + 1, 1 To k)
49
Pfreq = .Transpose(vR)
50
End With
51
Exit Function
52
ErrHdl:
53
If Err.Number = 9 Then
54
    If i > lvdim Then
55
        'Here we normally get if we breach Ubound(vR,2)
56
        'So we need to increase last dimension
57
        lvdim = 10 * lvdim
58
        If lvdim > UBound(v(0)) Then lvdim = UBound(v(0))
59
        ReDim Preserve vR(0 To UBound(v) + 1, 1 To lvdim)
60
        Err.Number = 0
61
        Resume 'Back to statement which caused error
62
    End If
63
End If
64
'Other error - terminate
65
On Error GoTo 0
66
Resume
67
End Function
Copied!
​
​

Mfreq

sbMiniPivot

Last modified 1yr ago

Copy link