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.
Function Pfreq(ParamArray v()) As Variant
'Pfreq lists how often each value combination
'in paramarray appears. 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
'=Pfreq(A1:A5,B1:B5) and you will get
'    C   D    E
' 1 Smith  Adam  2
' 2 Myer   Ben   2
' 3 Smith  Ben   1
'Reverse("moc.liborplus.www") V0.4 15-Oct-2009
Dim obj 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")
k = 0
v(0) = .Transpose(.Transpose(v(0)))
lvdim = UBound(v(0))
If lvdim > 100 Then lvdim = 100
On Error GoTo ErrHdl
ReDim vR(0 To UBound(v) + 1, 1 To lvdim)
For i = 1 To UBound(v(0))
    s = v(0)(i, 1)
    For j = 1 To UBound(v)
        v(j) = .Transpose(.Transpose(v(j)))
        s = s & sC & v(j)(i, 1)
    Next j
    If obj.Item(s) > 0 Then
        vR(UBound(v) + 1, obj.Item(s)) = vR(UBound(v) + 1, obj.Item(s)) + 1
    Else
        k = k + 1
        obj.Item(s) = k
        For j = 0 To UBound(v)
            vR(j, k) = v(j)(i, 1)
        Next j
        vR(UBound(v) + 1, k) = 1
    End If
Next i
If k > 0 Then ReDim Preserve vR(0 To UBound(v) + 1, 1 To k)
Pfreq = .Transpose(vR)
End With
Exit Function
ErrHdl:
If Err.Number = 9 Then
    If i > lvdim Then
        'Here we normally get if we breach Ubound(vR,2)
        'So we need to increase last dimension
        lvdim = 10 * lvdim
        If lvdim > UBound(v(0)) Then lvdim = UBound(v(0))
        ReDim Preserve vR(0 To UBound(v) + 1, 1 To lvdim)
        Err.Number = 0
        Resume 'Back to statement which caused error
    End If
End If
'Other error - terminate
On Error GoTo 0
Resume
End Function
​
​

Mfreq

sbMiniPivot

Last modified 2yr ago

Copy link