Allocating costs across a period of time

[Phil B]

I am writing a procedure that involves allocating a series of costs over a
series of months using a VBA. I am using "DateDiff" to calculate the number
of full months however the only way I know how to calculate part months is
through a series of logic tests and this does not seem to a very efficient
way. Is there a better way of allocating these costs across a range of
months.

 

[Doug Robbins - Word MVP]

It is not clear exactly what you want to determine. Give us an example and
show us the code that you are using for possible suggestions on ways to
improve it.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

 

[Phil B]

The following extract works out if the date range is made up of complete
months so that I can apportion the costs and assing them to an array.

a = Cells(7, 11)
b = Cells(8, 11)

'Whole months
If Day(a) = 1 Then
If Month(b) = 1 Or Month(b) = 3 Or Month(b) = 5 Or Month(b) = 7 Or
Month(b) = 8 Or Month(b) = 10 Or Month(b) = 12 And Day(b) = 31 Then
c = DateDiff("m", a - 1, b, 1)
For Mnth = 1 To c
Cost(Mnth) = Exp / 12
Next c
End If
If Month(b) = 4 Or Month(b) = 6 Or Month(b) = 9 Or Month(b) = 11 And
Day(b) = 30 Then
c = DateDiff("m", a - 1, b, 1)
For Mnth = 1 To c
Cost(Mnth) = Exp / 12
Next c
End If
If Month(b) = 2 And Year(b) Mod 4 = 0 And Day(b) = 29 Or Month(b) = 2
And Year(b) Mod 4 <> 0 And Day(b) = 28 Then
c = DateDiff("m", a - 1, b, 1)
For Mnth = 1 To c
Cost(Mnth) = Exp / 12
Next c
End If
End If

For those dates ranges which are not complete months I have then done
similar logic and then apportion the costs based on the number of days the
costs are valid for.

I can't believe this is the most efficient way of doing this and looking for
ideas.

Many thanks in advance.

 

[Doug Robbins - Word MVP]

The following allocates the amount to each month on the basis of the days in
the month and a rate per day determined by dividing the amount to be
allocated by the total number of days:

Dim Date1 As Date, Date2 As Date
Dim Nummonths As Long, startday As Long, endday As Long, startmonth As Long,
numdays As Long
Dim StartMonthDays As Long, EndMonthDays As Long
Dim DaysStart As Long, DaysEndMonth As Long
Dim amount As Long, amounts As String
Dim monthnum As Long, monthdays As Long
Dim amountbymonth As Variant
amount = 1000
Date1 = Date
Date2 = #2/15/2009#
startmonth = Format(Date2, "m")
startday = Format(Date2, "d")
endday = Format(Date1, "d")
numdays = DateDiff("d", Date2, Date1)
Nummonths = DateDiff("m", Date2, Date1)
Select Case startmonth
Case 1, 3, 5, 7, 8, 10, 12
StartMonthDays = 31
Case 4, 6, 9, 11
StartMonthDays = 30
Case Else
If Format(Date2, "yyyy") Mod 4 = 0 Then
StartMonthDays = 29
Else
StartMonthDays = 28
End If
End Select
amounts = amounts & Format((StartMonthDays - startday) * amount / numdays,
"#.00")
For i = 1 To Nummonths - 1
Select Case startmonth + i
Case 1, 3, 5, 7, 8, 10, 12
monthdays = 31
Case 4, 6, 9, 11
monthdays = 30
Case Else
If Format(Date2, "yyyy") Mod 4 = 0 Then
monthdays = 29
Else
monthdays = 28
End If
End Select
amounts = amounts & "|" & Format(monthdays * amount / numdays, "#.00")
Next i
amounts = amounts & "|" & Format(endday * amount / numdays, "#.00")
amountbymonth = Split(amounts, "|")
For i = 0 To UBound(amountbymonth)
MsgBox "Amount for " & Format(DateAdd("m", i, Date2), "mmmm yyyy") & "
is $" & amountbymonth(i)
Next i


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com

 

[Doug Robbins - Word MVP]

There were a few unnecessary declarations in the previous version. In
addition, I have modified it so that it handles the period extending over
the end of one year and also the varying number of days in February when
there is a leap year event. I have also added a check on the total of the
amounts for each month.

Dim Date1 As Date, Date2 As Date
Dim Nummonths As Long, startday As Long, endday As Long, startmonth As Long,
numdays As Long
Dim StartMonthDays As Long
Dim amount As Long, amounts As String
Dim monthdays As Long
Dim amountbymonth As Variant
Dim thismonth As Long
Dim Total As Double
amount = 200000
Date1 = Date
Date2 = #11/15/2007#
startmonth = Format(Date2, "m")
startday = Format(Date2, "d")
endday = Format(Date1, "d")
numdays = DateDiff("d", Date2, Date1)
Nummonths = DateDiff("m", Date2, Date1)

Select Case startmonth
Case 1, 3, 5, 7, 8, 10, 12
StartMonthDays = 31
Case 4, 6, 9, 11
StartMonthDays = 30
Case Else
If ((Format(Date2, "yyyy") Mod 4 = 0 And Format(Date2, "yyyy") Mod
400 = 0) Or Format(Date2, "yyyy") Mod 4 = 0 And Format(Date2, "yyyy") Mod
100 <> 0) Then
StartMonthDays = 29
Else
StartMonthDays = 28
End If
End Select
amounts = amounts & Format((StartMonthDays - startday) * amount / numdays,
"#.00")
For i = 1 To Nummonths - 1
thismonth = (startmonth + i) Mod 12
If thismonth = 0 Then
thismonth = 12
End If
Select Case thismonth
Case 1, 3, 5, 7, 8, 10, 12
monthdays = 31
Case 4, 6, 9, 11
monthdays = 30
Case Else
If ((Format(DateAdd("m", i, Date2), "yyyy") Mod 4 = 0 And
Format(DateAdd("m", i, Date2), "yyyy") Mod 400 = 0) Or Format(DateAdd("m",
i, Date2), "yyyy") Mod 4 = 0 And Format(DateAdd("m", i, Date2), "yyyy") Mod
100 <> 0) Then
monthdays = 29
Else
monthdays = 28
End If
End Select
amounts = amounts & "|" & Format(monthdays * amount / numdays, "#.00")
Next i
amounts = amounts & "|" & Format(endday * amount / numdays, "#.00")
amountbymonth = Split(amounts, "|")
For i = 0 To UBound(amountbymonth)
Total = Total + Val(amountbymonth(i))
MsgBox "Amount for " & Format(DateAdd("m", i, Date2), "mmmm yyyy") & "
is $" & amountbymonth(i)
Next i
MsgBox Total 'Check total

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP, originally posted via msnews.microsoft.com