Sulprobil
Search…
sbMiniPivot
Previous name was Pstat
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
Last modified 1yr ago
Copy link