Date functions are a pain, months and years don't have a standard length and do we want to include both beginning and end dates when figuring out time periods? the further you go into the details of date ranges the more knotty the calculations become. That said a few well placed vba functions can help - to that end here's a bunch to get you started and can be tweaked for a number of purposes:
' wraps the DateDiff function for use on a worksheet
Public Function GetDateDiff(ByVal DuratType As String, ByVal StartDate As Date, ByVal EndDate As Date _
, Optional FirstDayOfWeek As VbDayOfWeek = vbSunday _
, Optional FirstWeekOfYear As VbFirstWeekOfYear = vbFirstJan1) As Integer
GetDateDiff = DateDiff(DuratType, StartDate, EndDate, FirstDayOfWeek, FirstWeekOfYear)
End Function
' wraps the DateAdd function for use on a worksheet
Public Function GetDateAdd(interval As String, initialDate As Date, Value As Double) As Date
GetDateAdd = DateAdd(interval, Value, initialDate)
End Function
' Gives a specific function to enable a period presented as a year decimal to be added to a date
Public Function DateAddYrDec(initial As Date, yeardecimal As Double) As Date
DateAddYrDec = DateAdd("M", yeardecimal * 12, initial)
End Function
' Returns a decimal to represent a time period based on years and days/365
Public Function GetYrsDaysDecimal(ByVal StartDate As Date, ByVal EndDate As Date, _
Optional RoundTo As Integer = 4) As Double
Dim Yrs As Integer
Dim Days As Integer
Yrs = GetCompleteYears(StartDate, EndDate)
Days = DateDiff("d", DateAdd("yyyy", Yrs, StartDate), EndDate) - 1
Dim out As Double
out = Yrs + (Days / 365)
GetYrsDaysDecimal = Round(out, RoundTo)
End Function
' Returns a year decimal based on complete years and months between two dates
Public Function GetYrsMthDecimal(ByVal StartDate As Date, ByVal EndDate As Date, _
Optional RoundTo As Integer = 4, Optional Absolute As Boolean = False) As Double
Dim res As Double
res = Round((GetCompleteMonths(StartDate, EndDate)) / 12 _
, RoundTo)
If Absolute And EndDate <= StartDate Then res = res * -1
GetYrsMthDecimal = res
End Function
' Returns a year decimal based on the years, months and month percentage between two dates
Public Function GetYrsMthPercDecimal(ByVal StartDate As Date, ByVal EndDate As Date, _
Optional RoundTo As Integer = 4) As Double
Dim res As Double
res = Round((DateDiff("M", StartDate, EndDate) + MonthDiffDec(StartDate, EndDate)) / 12 _
, RoundTo)
If EndDate <= StartDate Then res = res * -1
GetYrsMthPercDecimal = res
End Function
' Returns a number representing the percentage of month between two given dates, ignoring years
Public Function MonthDiffDec(varDateFrom As Variant, Optional varDateTo As Variant) As Variant
Dim intMonths As Integer
Dim IntDays As Integer
If Not IsNull(varDateFrom) Then
If IsMissing(varDateTo) Then varDateTo = VBA.Date
intMonths = DateDiff("m", varDateFrom, varDateTo) - (GetAge(varDateFrom, varDateTo) * 12)
If Day(varDateFrom) > Day(varDateTo) Then
intMonths = intMonths - 1
IntDays = varDateTo - DateSerial(Year(varDateTo), Month(varDateTo) - 1, Day(varDateFrom))
Else
IntDays = varDateTo - DateSerial(Year(varDateTo), Month(varDateTo), Day(varDateFrom))
End If
MonthDiffDec = intMonths + IntDays / Day(DateSerial(Year(varDateTo), Month(varDateTo) + 1, 0))
End If
End Function
' Returns an integer of complete years for the passed dates
Public Function GetAge(varDoB As Variant, Optional varAgeAt As Variant) As Integer
If IsMissing(varAgeAt) Then varAgeAt = VBA.Date
GetAge = DateDiff("yyyy", varDoB, varAgeAt) - _
IIf(Format(varAgeAt, "mmdd") < Format(varDoB, "mmdd"), 1, 0)
End Function
' returns the month end for the date given
Public Function GetMonthEnd(PassDate As Date) As Date
Dim carry As Date
carry = DateSerial(Year(PassDate), Month(PassDate), 1)
carry = DateAdd("M", 1, carry)
carry = DateAdd("D", -1, carry)
GetMonthEnd = carry
End Function
' returns complete months from DateDiff, correcting for whole months rather than using month separators (counting the first)
Public Function GetCompleteMonths(StartDate As Date, EndDate As Date) As Integer
Dim Mths As Integer
Mths = DateDiff("m", StartDate, EndDate)
If Day(StartDate) > Day(EndDate) Then Mths = Mths - 1
GetCompleteMonths = Mths
End Function
' returns the number of whole years between two dates
Public Function GetCompleteYears(StartDate As Date, EndDate As Date) As Integer
If StartDate >= EndDate Then
GetCompleteYears = 0
Exit Function
End If
Dim FullYrs, YrDiff As Integer
' get the number of years difference
YrDiff = DatePart("yyyy", EndDate) - DatePart("yyyy", StartDate)
If DatePart("m", StartDate) < DatePart("m", EndDate) Or _
(DatePart("m", StartDate) = DatePart("m", EndDate) And DatePart("d", StartDate) <= DatePart("d", EndDate)) Then
' if the start date was before or equal to the end date in months and days
' full years is fine
FullYrs = YrDiff
Else
' otherwise we're cutting, minus one
FullYrs = YrDiff - 1
End If
GetCompleteYears = FullYrs
End Function
' Returns the number of complete tax years between two dates
Public Function GetCompleteTaxYears(StartDate As Date, EndDate As Date) As Integer
If StartDate >= EndDate Then
GetCompleteTaxYears = 0
Exit Function
End If
Dim TaxYrs As Integer
' get the number of years difference
TaxYrs = DatePart("yyyy", EndDate) - DatePart("yyyy", StartDate)
If DatePart("m", StartDate) > 4 Or _
(DatePart("m", StartDate) = 4 And DatePart("d", StartDate) > 6) Then
' we started after the start of the tax year, take one off
TaxYrs = TaxYrs - 1
End If
If DatePart("m", EndDate) < 4 Or _
(DatePart("m", EndDate) = 4 And DatePart("d", EndDate) < 5) Then
' we ended before the end of the tax year, take one off
TaxYrs = TaxYrs - 1
End If
GetCompleteTaxYears = TaxYrs
End Function
' Returns the number of occurences of a day/month between two dates
Public Function GetDateOccurrences(Day As Integer, Month As Integer, StartDate As Date, EndDate As Date, _
Optional inclusiveStart As Boolean = True, Optional inclusiveEnd As Boolean = True) As Integer
If StartDate > EndDate Then
GetDateOccurrences = 0
Exit Function
ElseIf StartDate = EndDate And (inclusiveStart Or inclusiveEnd) Then
GetDateOccurrences = 1
Exit Function
End If
Dim AnnivYrs, YrDiff As Integer
' get the number of years difference
YrDiff = DatePart("yyyy", EndDate) - DatePart("yyyy", StartDate)
Dim startBefore, endAfter As Boolean
If inclusiveStart Then
startBefore = DatePart("m", StartDate) < Month Or _
(DatePart("m", StartDate) = Month And DatePart("d", StartDate) <= Day)
Else
startBefore = DatePart("m", StartDate) < Month Or _
(DatePart("m", StartDate) = Month And DatePart("d", StartDate) < Day)
End If
If inclusiveEnd Then
endAfter = DatePart("m", EndDate) > Month Or _
(DatePart("m", EndDate) = Month And DatePart("d", EndDate) >= Day)
Else
endAfter = DatePart("m", EndDate) > Month Or _
(DatePart("m", EndDate) = Month And DatePart("d", EndDate) > Day)
End If
If startBefore <> endAfter Then
AnnivYrs = YrDiff
ElseIf startBefore Then
AnnivYrs = YrDiff + 1
Else
AnnivYrs = YrDiff - 1
End If
GetDateOccurrences = AnnivYrs
End Function
' Returns a list of date occurences between two dates (not for worksheet use)
Public Function GetDateOccurrencesList(Day As Integer, Month As Integer, StartDate As Date, EndDate As Date, _
Optional inclusiveStart As Boolean = True, Optional inclusiveEnd As Boolean = True) As Date()
Dim NoOccurrences As Integer
Dim startBefore As Boolean
Dim StartYr As Integer
Dim emptyArr() As Date
NoOccurrences = GetDateOccurrences(Day, Month, StartDate, EndDate, inclusiveStart, inclusiveEnd)
If NoOccurrences = 0 Then
GetDateOccurrencesList = emptyArr
Exit Function
End If
Dim DateArr() As Date
If StartDate > EndDate Then
' passing back the empty array
GetDateOccurrencesList = DateArr
Exit Function
ElseIf StartDate = EndDate And (inclusiveStart Or inclusiveEnd) Then
ReDim DateArr(0)
DateAdd(0) = StartDate
GetDateOccurrencesList = DateArr
Exit Function
End If
ReDim DateArr(NoOccurrences - 1)
If inclusiveStart Then
startBefore = DatePart("m", StartDate) < Month Or _
(DatePart("m", StartDate) = Month And DatePart("d", StartDate) <= Day)
Else
startBefore = DatePart("m", StartDate) < Month Or _
(DatePart("m", StartDate) = Month And DatePart("d", StartDate) < Day)
End If
If startBefore Then
StartYr = Year(StartDate)
Else
StartYr = Year(StartDate) + 1
End If
Dim i As Integer
For i = 0 To UBound(DateArr)
DateArr(i) = DateSerial(StartYr, Month, Day)
StartYr = StartYr + 1
Next i
GetDateOccurrencesList = DateArr
End Function
' Returns the date of the preceeding 6th of april from the passed date
Public Function GetPreceeding64(TestDate As Date) As Date
If Month(TestDate) < 4 Or _
(Month(TestDate) = 4 And Day(TestDate) < 6) Then
GetPreceeding64 = DateSerial(Year(TestDate) - 1, 4, 6)
Else
GetPreceeding64 = DateSerial(Year(TestDate), 4, 6)
End If
End Function
' Returns the date of the preceeding passed anniversary for the passed date
Public Function GetPreceedingAnniversary(pDay As Integer, pMonth As Integer, TestDate As Date) As Date
If pMonth = 2 And pDay = 29 Then
' we're looking for a leap year
Dim YearDiv As Double
Dim WholeYearDiv As Integer
YearDiv = Year(TestDate) / 4
WholeYearDiv = Year(TestDate) \ 4
If Month(TestDate) < pMonth Or _
(Month(TestDate) = pMonth And Day(TestDate) <= pDay) Then
' Earlier than/on anniv, looking for preceeding leap year
If YearDiv = WholeYearDiv Then
' We're in a leap year, get the one before it!
GetPreceedingAnniversary = DateSerial((YearDiv - 1) * 4, pMonth, pDay)
Else
' this isn't a leap year, get 4 * YearDiv
GetPreceedingAnniversary = DateSerial(YearDiv * 4, pMonth, pDay)
End If
Else
' passed anniv in this year, is this a leap year?
If YearDiv = WholeYearDiv Then
' We're in a leap year, get this one!
GetPreceedingAnniversary = DateSerial(Year(TestDate), pMonth, pDay)
Else
' this isn't a leap year, get the one before it (get 4 * YearDiv)
GetPreceedingAnniversary = DateSerial(YearDiv * 4, pMonth, pDay)
End If
End If
ElseIf Month(TestDate) < pMonth Or _
(Month(TestDate) = pMonth And Day(TestDate) <= pDay) Then
' less than or = to anniversary, get last year
GetPreceedingAnniversary = DateSerial(Year(TestDate) - 1, pMonth, pDay)
Else
' Have passed the anniversary this year, get this year
GetPreceedingAnniversary = DateSerial(Year(TestDate), pMonth, pDay)
End If
End Function
;){kind=link}
;){kind=link}
;){kind=link}
;){kind=link}