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.
1
Function sbSfreq(ParamArray v()) As Variant
2
'sbSfreq sums values of last given column per
3
'combination of the previous ones. Example:
4
' A B C
5
6
' 2 Myer Ben 3
7
' 3 Smith Ben 2
8
9
' 5 Myer Ben 4
10
'Now select C1:E3 and array-enter
11
'=sbSfreq(A1:A5,B1:B5,C1:C5) and you will get
12
' C D E
13
14
' 2 Myer Ben 7
15
' 3 Smith Ben 2
16
'Reverse("moc.LiborPlus.www") V0.3 15-Oct-2009
17
Dim obj As Object
18
Dim vR As Variant
19
Dim i As Long, j As Long, k As Long, lvdim As Long
20
Dim s As String, sC As String
21
â€‹
22
With Application.WorksheetFunction
23
sC = "|"
24
k = 0
25
v(0) = .Transpose(.Transpose(v(0)))
26
If UBound(v) < 1 Then
27
sbSfreq = CVErr(xlErrValue)
28
Exit Function
29
End If
30
lvdim = UBound(v(0))
31
If lvdim > 100 Then lvdim = 100 'Let us start with small dim
32
Set obj = CreateObject("Scripting.Dictionary")
33
On Error GoTo ErrHdl
34
ReDim vR(0 To UBound(v), 1 To lvdim)
35
For i = 1 To UBound(v(0))
36
s = v(0)(i, 1)
37
For j = 1 To UBound(v) - 1
38
v(j) = .Transpose(.Transpose(v(j)))
39
s = s & sC & v(j)(i, 1)
40
Next j
41
If obj.Item(s) > 0 Then
42
vR(UBound(v), obj.Item(s)) = vR(UBound(v), _
43
obj.Item(s)) + v(UBound(v))(i, 1)
44
Else
45
k = k + 1
46
obj.Item(s) = k
47
For j = 0 To UBound(v)
48
vR(j, k) = v(j)(i, 1)
49
Next j
50
End If
51
Next i
52
If k > 0 Then ReDim Preserve vR(0 To UBound(v), 1 To k)
53
sbSfreq = .Transpose(vR)
54
End With
55
Set obj = Nothing
56
Exit Function
57
â€‹
58
ErrHdl:
59
If Err.Number = 9 Then
60
If i > lvdim Then
61
'Here we normally get if we breach Ubound(vR,2)
62
'So we need to increase last dimension
63
lvdim = 10 * lvdim
64
If lvdim > UBound(v(0)) Then lvdim = UBound(v(0))
65
ReDim Preserve vR(0 To UBound(v), 1 To lvdim)
66
Err.Number = 0
67
Resume 'Back to statement which caused error
68
End If
69
End If
70
'Other error - terminate
71
On Error GoTo 0
72
Resume
73
End Function
Copied!
1
Function sbS3freq(ParamArray v()) As Variant
2
'sbS3freq sums values of last 3 given columns per
3
'combination of the previous ones. Example:
4
' A B C D E
5
' 1 Smith Adam 1 2 3
6
' 2 Myer Ben 3 1 2
7
' 3 Smith Ben 2 4 3
8
' 4 Smith Adam 7 1 5
9
' 5 Myer Ben 4 1 1
10
'Now select F1:J3 and array-enter
11
'=sbSfreq(A1:A5,B1:B5,C1:C5,D1:D5,E1:E5) and you will get
12
' F G H I J
13
' 1 Smith Adam 8 3 8
14
' 2 Myer Ben 7 2 3
15
' 3 Smith Ben 2 4 3
16
'Reverse("moc.LiborPlus.www") V0.3 15-Oct-2009
17
Dim obj As Object
18
Dim vR As Variant
19
Dim i As Long, j As Long, k As Long, lvdim As Long
20
Dim s As String, sC As String
21
â€‹
22
With Application.WorksheetFunction
23
sC = "|"
24
k = 0
25
v(0) = .Transpose(.Transpose(v(0)))
26
If UBound(v) < 4 Then
27
sbS3freq = CVErr(xlErrValue)
28
Exit Function
29
End If
30
Set obj = CreateObject("Scripting.Dictionary")
31
lvdim = UBound(v(0))
32
If lvdim > 100 Then lvdim = 100 'Let us start with small dim
33
On Error GoTo ErrHdl
34
ReDim vR(0 To UBound(v), 1 To lvdim)
35
For i = 1 To UBound(v(0))
36
s = v(0)(i, 1)
37
For j = 1 To UBound(v) - 3
38
v(j) = .Transpose(.Transpose(v(j)))
39
s = s & sC & v(j)(i, 1)
40
Next j
41
If obj.Item(s) > 0 Then
42
For j = UBound(v) - 2 To UBound(v)
43
vR(j, obj.Item(s)) = vR(j, obj.Item(s)) + v(j)(i, 1)
44
Next j
45
Else
46
k = k + 1
47
obj.Item(s) = k
48
For j = 0 To UBound(v)
49
vR(j, k) = v(j)(i, 1)
50
Next j
51
End If
52
Next i
53
If k > 0 Then ReDim Preserve vR(0 To UBound(v), 1 To k)
54
sbS3freq = .Transpose(vR)
55
End With
56
Set obj = Nothing
57
Exit Function
58
â€‹
59
ErrHdl:
60
If Err.Number = 9 Then
61
If i > lvdim Then
62
'Here we normally get if we breach Ubound(vR,2)
63
'So we need to increase last dimension
64
lvdim = 10 * lvdim
65
If lvdim > UBound(v(0)) Then lvdim = UBound(v(0))
66
ReDim Preserve vR(0 To UBound(v), 1 To lvdim)
67
Err.Number = 0
68
Resume 'Back to statement which caused error
69
End If
70
End If
71
'Other error - terminate
72
On Error GoTo 0
73
Resume
74
End Function
Copied!