Option Explicit
    
Enum mc_Macro_Categories
    mcFinancial = 1
    mcDate_and_Time
    mcMath_and_Trig
    mcStatistical
    mcLookup_and_Reference
    mcDatabase
    mcText
    mcLogical
    mcInformation
    mcCommands
    mcCustomizing
    mcMacro_Control
    mcDDE_External
    mcUser_Defined
    mcFirst_custom_category
    mcSecond_custom_category 'and so on
End Enum 'mc_Macro_Categories

Function sbMiniPivot(sFunction As String, _
         vCondition() As Variant, _
         ParamArray vInput() As Variant) As Variant
'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.
'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:F2 and array-enter
'=sbMiniPIvot("sum", B1:B5="Ben", A1:A5,B1:B5,C1:C5) and you will get
'    D      E    F
' 1 Myer   Ben   7
' 2 Smith  Ben   2
'Source (EN): http://www.sulprobil.com/sbminipivot_en/
'Source (DE): http://www.bplumhoff.de/sbminipivot_de/
'(C) (P) by Bernd Plumhoff 29-Jun-2019 PB V1.0
Dim obj As Object
Dim vR As Variant
Dim i As Long, j As Long, k As Long
Dim lvdim As Long, lcdim As Long
Dim s As String, sC As String
Dim liscount As Long '1 if and only if we count

With Application.WorksheetFunction
sC = "|"
k = 0
vInput(0) = .Transpose(.Transpose(vInput(0)))
If LCase(sFunction) = "count" Then liscount = 1
If UBound(vInput) < 1 - liscount Then
   sbMiniPivot = CVErr(xlErrValue)
   Exit Function
End If
vCondition = .Transpose(.Transpose(vCondition))
lcdim = UBound(vCondition, 1)
lvdim = UBound(vInput(0))
If lcdim <> lvdim Then
   sbMiniPivot = CVErr(xlErrRef)
   Exit Function
End If
If lvdim > 100 Then lvdim = 100 'Let us start with small dimension
On Error GoTo ErrHdl
ReDim vR(0 To UBound(vInput) + liscount, 1 To lvdim)
For j = 1 To UBound(vInput)
   vInput(j) = .Transpose(.Transpose(vInput(j)))
   If lcdim <> UBound(vInput(j)) Then
       sbMiniPivot = CVErr(xlErrRef)
       Exit Function
   End If
Next j
Set obj = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(vInput(0))
   If vCondition(i, 1) Then
       s = vInput(0)(i, 1)
       For j = 1 To UBound(vInput) - 1 + liscount
           s = s & sC & vInput(j)(i, 1)
       Next j
       If obj.Item(s) > 0 Then
           Select Case LCase(sFunction)
           Case "cat", "concatenate"
               vR(UBound(vInput), obj.Item(s)) = vR(UBound(vInput), _
                   obj.Item(s)) & "," & vInput(UBound(vInput))(i, 1)
           Case "count"
               vR(UBound(vInput) + 1, obj.Item(s)) = vR(UBound(vInput) + 1, _
                   obj.Item(s)) + 1
           Case "max", "maximum"
               If vR(UBound(vInput), obj.Item(s)) < vInput(UBound(vInput))(i, 1) Then
                   vR(UBound(vInput), obj.Item(s)) = vInput(UBound(vInput))(i, 1)
               End If
           Case "min", "minimum"
               If vR(UBound(vInput), obj.Item(s)) > vInput(UBound(vInput))(i, 1) Then
                   vR(UBound(vInput), obj.Item(s)) = vInput(UBound(vInput))(i, 1)
               End If
           Case "sum"
               vR(UBound(vInput), obj.Item(s)) = vR(UBound(vInput), _
                   obj.Item(s)) + vInput(UBound(vInput))(i, 1)
           Case Else
               sbMiniPivot = CVErr(xlErrRef)
           End Select
       Else
           k = k + 1
           obj.Item(s) = k
           For j = 0 To UBound(vInput)
               vR(j, k) = vInput(j)(i, 1)
           Next j
           If liscount = 1 Then vR(UBound(vInput) + 1, k) = 1
       End If
   End If
Next i
'Reduce result array to used area
If k > 0 Then ReDim Preserve vR(0 To UBound(vInput) + liscount, 1 To k)
sbMiniPivot = .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(vInput(0)) Then lvdim = UBound(vInput(0))
       ReDim Preserve vR(0 To UBound(vInput) + liscount, 1 To lvdim)
       Resume 'Back to statement which caused error
   End If
End If
'Other error - terminate
On Error GoTo 0
Resume
End Function

Sub DescribeFunction_sbMiniPivot()
'Run this only once, then you will see this description in the function menu
Dim FuncName As String, FuncDesc As String, Category As String
Dim ArgDesc(1 To 3) As String
FuncName = "sbMiniPivot"
FuncDesc = "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"
Category = mcStatistical
ArgDesc(1) = "Function to apply - cat, sum, min, or max"
ArgDesc(2) = "Condition column which needs to return True/False values"
ArgDesc(3) = "Two or more columns"
Application.MacroOptions _
    Macro:=FuncName, _
    Description:=FuncDesc, _
    Category:=Category, _
    ArgumentDescriptions:=ArgDesc
End Sub