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 array-enter into D1
'=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 31-Jul-2022 PB V1.1
Dim b As Boolean, bCondition As Boolean
Dim i As Long, j As Long, k As Long, liscount As Long
Dim lvdim As Long, lcdim As Long
Dim obj As Object
Dim s As String, sC As String
Dim vR As Variant

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
lvdim = UBound(vInput(0))
Select Case VarType(vCondition)
Case vbBoolean
    bCondition = True
Case vbArray + vbVariant
    bCondition = False
    vCondition = .Transpose(.Transpose(vCondition))
    lcdim = UBound(vCondition, 1)
    If lcdim <> lvdim Then
       sbMiniPivot = CVErr(xlErrRef)
       Exit Function
    End If
Case Else
   sbMiniPivot = CVErr(xlErrNA)
   Exit Function
End Select
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 UBound(vInput(0)) <> 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))
    b = bCondition
    If Not b Then b = vCondition(i, 1)
    If b 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, count, 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, count, max, min, or sum"
ArgDesc(2) = "Condition constant True or False or column which contains True/False values"
ArgDesc(3) = "Two or more columns"
Application.MacroOptions _
    Macro:=FuncName, _
    Description:=FuncDesc, _
    Category:=Category, _
    ArgumentDescriptions:=ArgDesc
End Sub