I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!

 

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.

sbMiniPivot

You can download a 27 KB Excel 2013 © sample file here but please notice my disclaimer.

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

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
'Reverse("moc.LiborPlus.www") V1.0 29-Jun-2019 (C) (P) by Bernd Plumhoff
'http://sulprobil.com/Get_it_done/IT/Excel_Fun/Excel_VBA/ListFreq/sbMiniPIvot/sbminipivot.html
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

Sulprobil   Get it done   Contact   Disclaimer   Impressum   Download