sbMiniPivot

If you want to apply a function like CAT, COUNT, MAX, MIN or SUM on a list of given number or string combinations with a condition applied, you can use sbMiniPivot.
Please note that sbMiniPivot("sum", {TRUE; ...; TRUE}, ...) is identical to Mfreq("sum", ...) and to sbSfreq(...). sbMiniPivot is an array function which has to be entered with CTRL + SHIFT + ENTER, not only with ENTER.
Name
sbMiniPivot - Concatenate, sum or return min or max of last given input column for all combinations of the previous ones where same row of condition column is True
Synopsis
sbMiniPivot(sFunction, vCondition, ParamArray vInput)
Description
sbMiniPivot performs the function sFunction on last given column of 'vInput for all combinations of the previous ones where corresponding elements of vCondition are True. It returns a variant array.
Options
sFunction
Specifies the function which has to be applied to the combinations. Can be concatenate (cat), count, max(imum), min(imum)
vCondition
Condition column which needs to return True/False values
vInput
Two or more columns. sFunction will be applied on last input column for all combinations of the previous ones where same row of condition column is True
Please read my Disclaimer.
1
Enum mc_Macro_Categories
2
    mcFinancial = 1
3
    mcDate_and_Time
4
    mcMath_and_Trig
5
    mcStatistical
6
    mcLookup_and_Reference
7
    mcDatabase
8
    mcText
9
    mcLogical
10
    mcInformation
11
    mcCommands
12
    mcCustomizing
13
    mcMacro_Control
14
    mcDDE_External
15
    mcUser_Defined
16
    mcFirst_custom_category
17
    mcSecond_custom_category 'and so on
18
End Enum 'mc_Macro_Categories
19
​
20
Function sbMiniPivot(sFunction As String, _
21
         vCondition() As Variant, _
22
         ParamArray vInput() As Variant) As Variant
23
'sbMiniPivot performs the function sFunction on last given column of
24
'vInput() for all combinations of the previous ones where corresponding
25
'elements of vCondition are TRUE.
26
'Example:
27
'    A     B     C
28
' 1 Smith Adam   1
29
' 2 Myer  Ben    3
30
' 3 Smith Ben    2
31
' 4 Smith Adam   7
32
' 5 Myer  Ben    4
33
'Now select D1:F2 and array-enter
34
'=sbMiniPIvot("sum", B1:B5="Ben", A1:A5,B1:B5,C1:C5) and you will get
35
'    D      E    F
36
' 1 Myer   Ben   7
37
' 2 Smith  Ben   2
38
'Reverse("moc.LiborPlus.www") V1.0 29-Jun-2019 (C) (P) by Bernd Plumhoff
39
'http://sulprobil.com/Get_it_done/IT/Excel_Fun/Excel_VBA/ListFreq/sbMiniPIvot/sbminipivot.html
40
Dim obj As Object
41
Dim vR As Variant
42
Dim i As Long, j As Long, k As Long
43
Dim lvdim As Long, lcdim As Long
44
Dim s As String, sC As String
45
Dim liscount As Long '1 if and only if we count
46
​
47
With Application.WorksheetFunction
48
sC = "|"
49
k = 0
50
vInput(0) = .Transpose(.Transpose(vInput(0)))
51
If LCase(sFunction) = "count" Then liscount = 1
52
If UBound(vInput) < 1 - liscount Then
53
   sbMiniPivot = CVErr(xlErrValue)
54
   Exit Function
55
End If
56
vCondition = .Transpose(.Transpose(vCondition))
57
lcdim = UBound(vCondition, 1)
58
lvdim = UBound(vInput(0))
59
If lcdim <> lvdim Then
60
   sbMiniPivot = CVErr(xlErrRef)
61
   Exit Function
62
End If
63
If lvdim > 100 Then lvdim = 100 'Let us start with small dimension
64
On Error GoTo ErrHdl
65
ReDim vR(0 To UBound(vInput) + liscount, 1 To lvdim)
66
For j = 1 To UBound(vInput)
67
   vInput(j) = .Transpose(.Transpose(vInput(j)))
68
   If lcdim <> UBound(vInput(j)) Then
69
       sbMiniPivot = CVErr(xlErrRef)
70
       Exit Function
71
   End If
72
Next j
73
Set obj = CreateObject("Scripting.Dictionary")
74
For i = 1 To UBound(vInput(0))
75
   If vCondition(i, 1) Then
76
       s = vInput(0)(i, 1)
77
       For j = 1 To UBound(vInput) - 1 + liscount
78
           s = s & sC & vInput(j)(i, 1)
79
       Next j
80
       If obj.Item(s) > 0 Then
81
           Select Case LCase(sFunction)
82
           Case "cat", "concatenate"
83
               vR(UBound(vInput), obj.Item(s)) = vR(UBound(vInput), _
84
                   obj.Item(s)) & "," & vInput(UBound(vInput))(i, 1)
85
           Case "count"
86
               vR(UBound(vInput) + 1, obj.Item(s)) = vR(UBound(vInput) + 1, _
87
                   obj.Item(s)) + 1
88
           Case "max", "maximum"
89
               If vR(UBound(vInput), obj.Item(s)) < vInput(UBound(vInput))(i, 1) Then
90
                   vR(UBound(vInput), obj.Item(s)) = vInput(UBound(vInput))(i, 1)
91
               End If
92
           Case "min", "minimum"
93
               If vR(UBound(vInput), obj.Item(s)) > vInput(UBound(vInput))(i, 1) Then
94
                   vR(UBound(vInput), obj.Item(s)) = vInput(UBound(vInput))(i, 1)
95
               End If
96
           Case "sum"
97
               vR(UBound(vInput), obj.Item(s)) = vR(UBound(vInput), _
98
                   obj.Item(s)) + vInput(UBound(vInput))(i, 1)
99
           Case Else
100
               sbMiniPivot = CVErr(xlErrRef)
101
           End Select
102
       Else
103
           k = k + 1
104
           obj.Item(s) = k
105
           For j = 0 To UBound(vInput)
106
               vR(j, k) = vInput(j)(i, 1)
107
           Next j
108
           If liscount = 1 Then vR(UBound(vInput) + 1, k) = 1
109
       End If
110
   End If
111
Next i
112
'Reduce result array to used area
113
If k > 0 Then ReDim Preserve vR(0 To UBound(vInput) + liscount, 1 To k)
114
sbMiniPivot = .Transpose(vR)
115
Set obj = Nothing
116
End With
117
Exit Function
118
​
119
ErrHdl:
120
If Err.Number = 9 Then
121
   If i > lvdim Then
122
       'Here we normally get if we breach Ubound(vR,2)
123
       'So we need to increase last dimension
124
       lvdim = 10 * lvdim
125
       If lvdim > UBound(vInput(0)) Then lvdim = UBound(vInput(0))
126
       ReDim Preserve vR(0 To UBound(vInput) + liscount, 1 To lvdim)
127
       Resume 'Back to statement which caused error
128
   End If
129
End If
130
'Other error - terminate
131
On Error GoTo 0
132
Resume
133
End Function
134
​
135
Sub DescribeFunction_sbMiniPivot()
136
'Run this only once, then you will see this description in the function menu
137
Dim FuncName As String, FuncDesc As String, Category As String
138
Dim ArgDesc(1 To 3) As String
139
FuncName = "sbMiniPivot"
140
FuncDesc = "Concatenate, sum or return min or max of last given input " & _
141
    "column for all combinations of the previous ones where same row " & _
142
    "of condition column is True"
143
Category = mcStatistical
144
ArgDesc(1) = "Function to apply - cat, sum, min, or max"
145
ArgDesc(2) = "Condition column which needs to return True/False values"
146
ArgDesc(3) = "Two or more columns"
147
Application.MacroOptions _
148
    Macro:=FuncName, _
149
    Description:=FuncDesc, _
150
    Category:=Category, _
151
    ArgumentDescriptions:=ArgDesc
152
End Sub
Copied!
sbMiniPivot.xlsm
40KB
Binary
sbMiniPivot.xlsm

Pfreq

sbSfreq

Last modified 1yr ago

Copy link