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.
Function Sfreq(ParamArray v()) As Variant
'Sfreq 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
'=Sfreq(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
Sfreq = 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)
Sfreq = .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 S3freq(ParamArray v()) As Variant
'S3freq 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
'=Sfreq(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
S3freq = 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)
S3freq = .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
If you need to sum the last THREE columns (just one example of a possible derivative function):
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.