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!

 

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 Pstat.

Please note that Pstat("sum", {TRUE; ...; TRUE}, ...) is identical to Mfreq("sum", ...) and to sbSfreq(...). Pstat is an array function which has to be entered with CTRL + SHIFT + ENTER, not only with ENTER.

Pstat_Example

Function Pstat(sFunction As String, _
               vCond() As Variant, _
               ParamArray v() As Variant) As Variant
'Pstat performs the function sFunction on last given column of v()
'for all combinations of the previous ones where corresponding
'elements of vCond 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
'=Pstat("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") V0.6 15-Oct-2009
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
v(0) = .Transpose(.Transpose(v(0)))
If LCase(sFunction) = "count" Then liscount = 1
If UBound(v) < 1 - liscount Then
   Pstat = CVErr(xlErrValue)
   Exit Function
End If
vCond = .Transpose(.Transpose(vCond))
lcdim = UBound(vCond, 1)
lvdim = UBound(v(0))
If lcdim <> lvdim Then
   Pstat = CVErr(xlErrRef)
   Exit Function
End If
If lvdim > 100 Then lvdim = 100 'Let us start with small dim
On Error GoTo ErrHdl 'Please read
                               'http://www.sulprobil.com/Get_it_done/IT/Excel_Fun/Excel_VBA/Error_Trapping/error_trapping.html
ReDim vR(0 To UBound(v) + liscount, 1 To lvdim)
For j = 1 To UBound(v)
   v(j) = .Transpose(.Transpose(v(j)))
   If lcdim <> UBound(v(j)) Then
       Pstat = CVErr(xlErrRef)
       Exit Function
   End If
Next j
Set obj = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(v(0))
   If vCond(i, 1) Then
       s = v(0)(i, 1)
       For j = 1 To UBound(v) - 1 + liscount
           s = s & sC & v(j)(i, 1)
       Next j
       If obj.Item(s) > 0 Then
           Select Case LCase(sFunction)
           Case "cat", "concatenate"
               vR(UBound(v), obj.Item(s)) = vR(UBound(v), _
                   obj.Item(s)) & "," & v(UBound(v))(i, 1)
           Case "count"
               vR(UBound(v) + 1, obj.Item(s)) = vR(UBound(v) + 1, _
                   obj.Item(s)) + 1
           Case "max", "maximum"
               If vR(UBound(v), obj.Item(s)) < v(UBound(v))(i, 1) Then
                   vR(UBound(v), obj.Item(s)) = v(UBound(v))(i, 1)
               End If
           Case "min", "minimum"
               If vR(UBound(v), obj.Item(s)) > v(UBound(v))(i, 1) Then
                   vR(UBound(v), obj.Item(s)) = v(UBound(v))(i, 1)
               End If
           Case "sum"
               vR(UBound(v), obj.Item(s)) = vR(UBound(v), _
                   obj.Item(s)) + v(UBound(v))(i, 1)
           Case Else
               Pstat = CVErr(xlErrRef)
           End Select
       Else
           k = k + 1
           obj.Item(s) = k
           For j = 0 To UBound(v)
               vR(j, k) = v(j)(i, 1)
           Next j
           If liscount = 1 Then vR(UBound(v) + 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(v) + liscount, 1 To k)
Pstat = .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(v(0)) Then lvdim = UBound(v(0))
       ReDim Preserve vR(0 To UBound(v) + liscount, 1 To lvdim)
       Err.Number = 0
       Resume 'Back to statement which caused error
   End If
End If
'Other error - terminate
On Error GoTo 0
Resume
End Function

Sulprobil   Get it done   Contact   Disclaimer   Download