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.
1
Function Mfreq(sFunction As String, ParamArray v()) As Variant
2
'Mfreq performs the function sFunction on last given column per
3
'combination of the previous ones. Example:
4
'    A     B     C
5
' 1 Smith Adam   1
6
' 2 Myer  Ben    3
7
' 3 Smith Ben    2
8
' 4 Smith Adam   7
9
' 5 Myer  Ben    4
10
'Now select D1:F3 and array-enter
11
'=Mfreq("sum",A1:A5,B1:B5,C1:C5) and you will get
12
'     D     E    F
13
' 1 Smith  Adam  8
14
' 2 Myer   Ben   7
15
' 3 Smith  Ben   2
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
If UBound(v) < 1 Then
28
    Mfreq = CVErr(xlErrValue)
29
    Exit Function
30
End If
31
lvdim = UBound(v(0))
32
If lvdim > 100 Then lvdim = 100 'Let us start with small dim
33
On Error GoTo ErrHdl 
34
ReDim vR(0 To UBound(v), 1 To lvdim)
35
For i = 1 To UBound(v(0))
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
        Select Case LCase(sFunction)
43
        Case "sum"
44
            vR(UBound(v), obj.Item(s)) = vR(UBound(v), _
45
                obj.Item(s)) + v(UBound(v))(i, 1)
46
        Case "max"
47
            If vR(UBound(v), obj.Item(s)) < v(UBound(v))(i, 1) Then
48
                vR(UBound(v), obj.Item(s)) = v(UBound(v))(i, 1)
49
            End If
50
        Case "min"
51
            If vR(UBound(v), obj.Item(s)) > v(UBound(v))(i, 1) Then
52
                vR(UBound(v), obj.Item(s)) = v(UBound(v))(i, 1)
53
            End If
54
        Case Else
55
            Mfreq = CVErr(xlErrRef)
56
        End Select
57
    Else
58
        k = k + 1
59
        obj.Item(s) = k
60
        For j = 0 To UBound(v) - 1
61
            vR(j, k) = v(j)(i, 1)
62
        Next j
63
        vR(UBound(v), k) = v(UBound(v))(i, 1)
64
    End If
65
Next i
66
'Reduce result array to used area
67
If k > 0 Then ReDim Preserve vR(0 To UBound(v), 1 To k)
68
Mfreq = .Transpose(vR)
69
Set obj = Nothing
70
End With
71
Exit Function
72
​
73
ErrHdl:
74
If Err.Number = 9 Then
75
   If i > lvdim Then
76
       'Here we normally get if we breach Ubound(vR,2)
77
       'So we need to increase last dimension
78
       lvdim = 10 * lvdim
79
       If lvdim > UBound(v(0)) Then lvdim = UBound(v(0))
80
       ReDim Preserve vR(0 To UBound(v), 1 To lvdim)
81
       Err.Number = 0
82
       Resume 'Back to statement which caused error
83
   End If
84
End If
85
'Other error - terminate
86
On Error GoTo 0
87
Resume
88
End Function
Copied!

Lfreq

Pfreq

Last modified 1yr ago

Copy link