“It’s not what you look at that matters, it’s what you see.” [Henry David Thoreau]

Bemerkung: Bitte beachten Sie dass Excel 365 Insider jetzt zwei ähnliche, aber mächtigere Tabellenblattfunktionen als sbMiniPivot anbietet - GROUPBY und PIVOTMIT. Sobald Ihr Excel auch über diese Funktionen verfügt, sollten Sie sbMiniPivot nur noch für VBA Trainingszwecke verwenden.

Abstract

Wenn Sie eine Funktion wie CAT, COUNT, MAX, MIN oder SUM auf eine Liste von Zahlen- oder Zeichenketten-Kombinationen anwenden wollen und dabei auch Nebenbedingungen erfüllt werden sollen, dann können Sie sbMiniPivot verwenden:

sbMiniPivot

Name

sbMiniPivot - Verbinde, zähle, summiere oder gib das Minimum oder Maximum der letzten gegebenen Eingabespalte zurück für alle Kombinationen der vorherigen Spalteneinträge bei der die entsprechende Zeile der Bedingungsspalte WAHR ist.

Synopsis

sbMiniPivot(sFunction, vCondition, ParamArray vInput)

Beschreibung

sbMiniPivot führt die Funktion sFunction für die letzte Spalte von vInput aus für alle Kombinationen der vorhergehenden Spalten bei der der entsprechende Wert in der Bedingungsspalte vCondition WAHR ist. Es wird ein Variant Array zurückgegeben.

Optionen

sFunction - Spezifiziert die Funktion, die auf alle Kombinationen angewendet wird. Dies kann concatenate (cat), count, max(imum), min(imum), oder sum sein.

vCondition - Die Bedingungskonstante WAHR oder FALSCH oder eine Spalte mit Boolschen WAHR/FALSCH Werten

vInput - Zwei oder mehr Spalten. sFunction wird auf die letzte Spalte für alle Kombinationen der vorigen Spalten angewandt bei der der entsprechende Wert der Bedingungsspalte WAHR ist.

Appendix – Programmcode sbMiniPivot

Bitte den Haftungsausschluss im Impressum beachten.

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.de/sbminipivot_en/
'Source (DE): http://www.berndplumhoff.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

Download

Bitte den Haftungsausschluss im Impressum beachten.

sbMiniPivot.xlsm [41 KB Excel Datei, ohne jegliche Gewährleistung]