Sulprobil
Search…
sbDistBudget
"Givers have to set limits because takers rarely do." [Irma Kurtz]
Suppose your company is in the middle of its annual process to plan its revenues and expenses. You are head of a division with 6 departments (A to F). Your department heads requested 2000, 1900, 2000, 2000, 600 and 2000 € but you only got a budget of 9000 € from your company. Your departments' weighted contributions to your company's revenues are 30%, 20%, 15%, 15%, 10% and 10%. How do you distribute your budget? You surely would not give them more than they have asked for...
Please read my Disclaimer.
1
Function sbDistBudget(dBudget As Double, _
2
vRequest As Variant, _
3
vWeight As Variant) As Variant
4
'Distribute a budget fairly upon Ubound(vRequest)
5
'requestors according to their weight vWeight(i)
6
'but do not give them more than they requested.
7
'Iterative solution.
8
'Reverse("moc.LiborPlus.www") PB V0.22 03-Dec-2012
9
Dim dSumRequest As Double
10
Dim dSumWeight As Double
11
Dim dSumDist As Double
12
Dim dBudgetRest As Double
13
Dim dMinRest As Double
14
Dim i As Long, lc As Long, lgtNull As Long
15
lc = vRequest.Count
16
If lc <> vWeight.Count Then
17
sbDistBudget = CVErr(xlErrValue)
18
Exit Function
19
End If
20
ReDim dWeight(1 To lc) As Double
21
ReDim vR(1 To lc) As Variant 'Result vector
22
ReDim vT(1 To lc) As Variant 'Temp vector
23
With Application.WorksheetFunction
24
dSumRequest = .Sum(vRequest)
25
If dSumRequest <= dBudget Then
26
'Easy case: budget >= requests
27
For i = 1 To lc
28
vR(i) = vRequest(i)
29
Next i
30
sbDistBudget = vR
31
Exit Function
32
End If
33
'Initialize budget distribution
34
dBudgetRest = dBudget
35
For i = 1 To lc
36
dWeight(i) = vWeight(i)
37
Next i
38
'Distribute budget
39
Do While dBudget > dSumDist
40
dSumWeight = .Sum(dWeight)
41
If dSumWeight > 0# Then
42
For i = 1 To lc
43
vT(i) = dWeight(i) * dBudgetRest / dSumWeight
44
If vT(i) + vR(i) >= vRequest(i) Then
45
vT(i) = vRequest(i) - vR(i)
46
dWeight(i) = 0#
47
End If
48
vR(i) = vR(i) + vT(i)
49
Next i
50
Else
51
lgtNull = 0
52
dMinRest = dBudgetRest
53
For i = 1 To lc
54
vT(i) = .Max(vRequest(i) - vR(i), 0#)
55
If vT(i) > 0# Then
56
lgtNull = lgtNull + 1
57
If dMinRest > vT(i) Then
58
dMinRest = vT(i)
59
End If
60
End If
61
Next i
62
If lgtNull = 0 Then Exit Do
63
If dMinRest > dBudgetRest / lgtNull Then
64
dMinRest = dBudgetRest / lgtNull
65
End If
66
For i = 1 To lc
67
If vT(i) > 0# Then
68
vR(i) = vR(i) + dMinRest
69
vT(i) = dMinRest
70
End If
71
Next i
72
End If
73
dBudgetRest = dBudgetRest - .Sum(vT)
74
dSumDist = .Sum(vR)
75
Loop
76
End With
77
sbDistBudget = vR
78
End Function
Copied!
sbDistBudget.xlsm
16KB
Binary
sbDistBudget.xlsm
Last modified 1yr ago
Copy link