Sulprobil
Search…
sbSfreq
Sum values for given string/number combinations.
Example: (Newsgroup Microsoft.Public.Excel.Misc 23-Feb-2009 15:10). I want to match the date of the expense and get a monthly total seperate for business and personal, the date of the expense and get a seperate yearly total for business and personal, the type of expense and get seperate overall totals for business and personal, the type of expense and get seperate totals for the type of payment seperated into business and personal.
Please read my Disclaimer.
Function sbSfreq(ParamArray v()) As Variant
'sbSfreq sums values of last given column per
'combination of the previous ones. 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 C1:E3 and array-enter
'=sbSfreq(A1:A5,B1:B5,C1:C5) and you will get
' C D E
' 1 Smith Adam 8
' 2 Myer Ben 7
' 3 Smith Ben 2
'Reverse("moc.LiborPlus.www") V0.3 15-Oct-2009
Dim obj As Object
Dim vR As Variant
Dim i As Long, j As Long, k As Long, lvdim As Long
Dim s As String, sC As String
With Application.WorksheetFunction
sC = "|"
k = 0
v(0) = .Transpose(.Transpose(v(0)))
If UBound(v) < 1 Then
sbSfreq = CVErr(xlErrValue)
Exit Function
End If
lvdim = UBound(v(0))
If lvdim > 100 Then lvdim = 100 'Let us start with small dim
Set obj = CreateObject("Scripting.Dictionary")
On Error GoTo ErrHdl
ReDim vR(0 To UBound(v), 1 To lvdim)
For i = 1 To UBound(v(0))
s = v(0)(i, 1)
For j = 1 To UBound(v) - 1
v(j) = .Transpose(.Transpose(v(j)))
s = s & sC & v(j)(i, 1)
Next j
If obj.Item(s) > 0 Then
vR(UBound(v), obj.Item(s)) = vR(UBound(v), _
obj.Item(s)) + v(UBound(v))(i, 1)
Else
k = k + 1
obj.Item(s) = k
For j = 0 To UBound(v)
vR(j, k) = v(j)(i, 1)
Next j
End If
Next i
If k > 0 Then ReDim Preserve vR(0 To UBound(v), 1 To k)
sbSfreq = .Transpose(vR)
End With
Set obj = Nothing
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), 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
Function sbS3freq(ParamArray v()) As Variant
'sbS3freq sums values of last 3 given columns per
'combination of the previous ones. Example:
' A B C D E
' 1 Smith Adam 1 2 3
' 2 Myer Ben 3 1 2
' 3 Smith Ben 2 4 3
' 4 Smith Adam 7 1 5
' 5 Myer Ben 4 1 1
'Now select F1:J3 and array-enter
'=sbSfreq(A1:A5,B1:B5,C1:C5,D1:D5,E1:E5) and you will get
' F G H I J
' 1 Smith Adam 8 3 8
' 2 Myer Ben 7 2 3
' 3 Smith Ben 2 4 3
'Reverse("moc.LiborPlus.www") V0.3 15-Oct-2009
Dim obj As Object
Dim vR As Variant
Dim i As Long, j As Long, k As Long, lvdim As Long
Dim s As String, sC As String
With Application.WorksheetFunction
sC = "|"
k = 0
v(0) = .Transpose(.Transpose(v(0)))
If UBound(v) < 4 Then
sbS3freq = CVErr(xlErrValue)
Exit Function
End If
Set obj = CreateObject("Scripting.Dictionary")
lvdim = UBound(v(0))
If lvdim > 100 Then lvdim = 100 'Let us start with small dim
On Error GoTo ErrHdl
ReDim vR(0 To UBound(v), 1 To lvdim)
For i = 1 To UBound(v(0))
s = v(0)(i, 1)
For j = 1 To UBound(v) - 3
v(j) = .Transpose(.Transpose(v(j)))
s = s & sC & v(j)(i, 1)
Next j
If obj.Item(s) > 0 Then
For j = UBound(v) - 2 To UBound(v)
vR(j, obj.Item(s)) = vR(j, obj.Item(s)) + v(j)(i, 1)
Next j
Else
k = k + 1
obj.Item(s) = k
For j = 0 To UBound(v)
vR(j, k) = v(j)(i, 1)
Next j
End If
Next i
If k > 0 Then ReDim Preserve vR(0 To UBound(v), 1 To k)
sbS3freq = .Transpose(vR)
End With
Set obj = Nothing
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), 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
Last modified 2yr ago
Copy link