Mfreq

If you want to apply a function like MIN, MAX or SUM on a list of given number or string combinations, you can use Mfreq.
Please note that Mfreq("sum", ...) is identical to sbSfreq(...). Mfreq is an array function which has to be entered with CTRL + SHIFT + ENTER, not only with ENTER.
Please read my Disclaimer.
Function Mfreq(sFunction As String, ParamArray v()) As Variant
'Mfreq performs the function sFunction on last given column per
'combination of the previous ones. Example:
'    A     B     C
' 1 Smith Adam   1
' 2 Myer  Ben    3
' 3 Smith Ben    2
' 4 Smith Adam   7
' 5 Myer  Ben    4
'Now select D1:F3 and array-enter
'=Mfreq("sum",A1:A5,B1:B5,C1:C5) and you will get
'     D     E    F
' 1 Smith  Adam  8
' 2 Myer   Ben   7
' 3 Smith  Ben   2
'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)))
If UBound(v) < 1 Then
    Mfreq = CVErr(xlErrValue)
    Exit Function
End If
lvdim = UBound(v(0))
If lvdim > 100 Then lvdim = 100 'Let us start with small dim
On Error GoTo ErrHdl 
ReDim vR(0 To UBound(v), 1 To lvdim)
For i = 1 To UBound(v(0))
    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
        Select Case LCase(sFunction)
        Case "sum"
            vR(UBound(v), obj.Item(s)) = vR(UBound(v), _
                obj.Item(s)) + v(UBound(v))(i, 1)
        Case "max"
            If vR(UBound(v), obj.Item(s)) < v(UBound(v))(i, 1) Then
                vR(UBound(v), obj.Item(s)) = v(UBound(v))(i, 1)
            End If
        Case "min"
            If vR(UBound(v), obj.Item(s)) > v(UBound(v))(i, 1) Then
                vR(UBound(v), obj.Item(s)) = v(UBound(v))(i, 1)
            End If
        Case Else
            Mfreq = CVErr(xlErrRef)
        End Select
    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)
    End If
Next i
'Reduce result array to used area
If k > 0 Then ReDim Preserve vR(0 To UBound(v), 1 To k)
Mfreq = .Transpose(vR)
Set obj = Nothing
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 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

Lfreq

Pfreq

Last modified 2yr ago

Copy link