Sulprobil
Search…
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!
Last modified 1yr ago
Copy link