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
Function IsLeapYear(ByVal Year As Long) As Boolean
' Check if divisible by 4, not divisible by 100, or divisible by 400
IsLeapYear = Year Mod 4 = 0 And (Year Mod 100 <> 0 Or Year Mod 400 = 0)
End Function
' Helper function for leap year days
Function GetLeapYearDays(ByVal StartDate As Date, ByVal EndDate As Date) As Integer
' Ensure StartDate is earlier than EndDate
If StartDate > EndDate Then
Dim tempDate As Date
tempDate = StartDate
StartDate = EndDate
EndDate = tempDate
End If
Dim years As Integer
' calculate years and remove the start and end years, we'll test those later
years = Year(EndDate) - Year(StartDate)
' grab the intervening years
For i = 0 To years
If IsLeapYear(Year(StartDate) + i) Then
GetLeapYearDays = GetLeapYearDays + 1
End If
Next i
If Month(StartDate) > 2 And IsLeapYear(Year(StartDate)) Then GetLeapYearDays = GetLeapYearDays - 1
If (Month(EndDate) < 2 Or (Month(EndDate) = 2 And Day(EndDate) < 29)) _
And IsLeapYear(Year(EndDate)) Then GetLeapYearDays = GetLeapYearDays - 1
End Function
' returns number of days for given month/year
Function DaysInMonth(ByVal Month As Integer, ByVal Year As Long) As Integer
' Validate month number
If Month < 1 Or Month > 12 Then
DaysInMonth = -1 ' Indicate invalid month
Exit Function
End If
' Array for days in non-leap years
Dim daysPerMonth(1 To 12) As Integer
For i = 1 To 12
Select Case i
Case 1, 3, 5, 7, 8, 10, 12
daysPerMonth(i) = 31
Case 4, 6, 9, 11
daysPerMonth(i) = 30
Case 2
daysPerMonth(i) = 28
End Select
Next i
' Add extra day for February in leap years
DaysInMonth = daysPerMonth(Month) + IIf(IsLeapYear(Year) And Month = 2, 1, 0)
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 year decimal based on the actual time between two dates
Public Function GetAccYrDecimal(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
GetAccYrDecimal = 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, correcting for whole months rather than using month separators (counting the first)
Public Function GetCompleteMonths(StartDate As Date, EndDate As Date) As Integer
Dim tempDate As Date
' ensure start is before end
If StartDate > EndDate Then
tempDate = StartDate
StartDate = EndDate
EndDate = tempDate
End If
Dim Yrs As Integer
Dim Mths As Integer
Yrs = GetCompleteYears(StartDate, EndDate)
tempDate = DateAdd("Y", Yrs, StartDate)
Mths = Yrs * 12
If Year(tempDate) = Year(EndDate) Then
Mths = Mths + Month(EndDate) - Month(StartDate)
Else
Mths = Mths + (12 - Month(StartDate)) + Month(EndDate)
End If
If Day(StartDate) > Day(EndDate) Then Mths = Mths - 1
GetCompleteMonths = Mths
End Function
' returns a month integer (1-12) based on an initally passed month and a number of months to add
' to get to whether a year has been added use the following: year = year + (MonthsToAdd \ 12)
Function CalculateMonth(ByVal StartMonth As Integer, ByVal MonthsToAdd As Integer) As Integer
' Validate input month
If StartMonth < 1 Or StartMonth > 12 Then
CalculateMonth = 0 ' Indicate an invalid input month
Exit Function
End If
' Calculate the new month with potential year rollover
Dim totalMonths As Integer
totalMonths = StartMonth + MonthsToAdd
Dim resultMonth As Integer
resultMonth = ((totalMonths - 1) Mod 12) + 1
CalculateMonth = resultMonth
End Function
' Returns the number of whole years between two dates
' If a 29/2 is passed as the start then the next 28/2 will not count as a full year
Public Function GetCompleteYears(StartDate As Date, EndDate As Date) As Integer
' Ensure StartDate is earlier than EndDate
If StartDate > EndDate Then
Dim tempDate As Date
tempDate = StartDate
StartDate = EndDate
EndDate = tempDate
End If
' Extract year, month, and day components
Dim startYear As Long, StartMonth As Integer, startDay As Integer
Dim endYear As Long, endMonth As Integer, endDay As Integer
startYear = Year(StartDate): StartMonth = Month(StartDate): startDay = Day(StartDate)
endYear = Year(EndDate): endMonth = Month(EndDate): endDay = Day(EndDate)
Dim FullYrs, YrDiff As Integer
' get the number of years difference
YrDiff = endYear - startYear
If StartMonth < endMonth Or _
(StartMonth = endMonth And startDay <= endDay) 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 an accurate number of days between two given dates
Function DaysBetweenDates(ByVal StartDate As Date, ByVal EndDate As Date) As Long
Dim tempDate As Date
' Ensure StartDate is earlier than EndDate
If StartDate > EndDate Then
tempDate = StartDate
StartDate = EndDate
EndDate = tempDate
End If
' Extract year, month, and day components
Dim startYear As Long, StartMonth As Integer, startDay As Integer
Dim endYear As Long, endMonth As Integer, endDay As Integer
startYear = Year(StartDate): StartMonth = Month(StartDate): startDay = Day(StartDate)
endYear = Year(EndDate): endMonth = Month(EndDate): endDay = Day(EndDate)
Dim days As Long, months As Integer, years As Integer
' Calculate difference in years and set a tempdate
years = GetCompleteYears(StartDate, EndDate)
tempDate = DateSerial(startYear + years, StartMonth, startDay)
' add the years days to our running total so that they're out of the way, only grab leap year days
days = (years * 365) + GetLeapYearDays(StartDate, tempDate)
' if we're in the same month and year just add the days and let's get out
If (Year(tempDate) = endYear) And endMonth = StartMonth Then
DaysBetweenDates = days + endDay - startDay ' + 1 here to include start day
Exit Function
End If
' see if there are any months intervening and grab the days for them
For i = 0 To GetCompleteMonths(tempDate, EndDate) - 1
days = days + DaysInMonth(CalculateMonth(StartMonth, i), Year(tempDate) + (i \ 12))
' set the tempDate to the date at the end of the period processed here
tempDate = DateSerial((Year(tempDate) + ((i + 1) \ 12)), CalculateMonth(StartMonth, i + 1), startDay)
Next i
' if we've landed in the same month then grab the day difference and return it
If endMonth = Month(tempDate) Then
DaysBetweenDates = days + endDay - startDay ' + 1 here to include start day
Exit Function
End If
' count up the remaining days in the start month month and add the days in the end month
days = days + DaysInMonth(Month(tempDate), Year(tempDate)) - startDay + endDay
DaysBetweenDates = days
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
' if we're looking for leap year days then just pass that
If Day = 29 And Month = 2 Then
GetDateOccurrences = GetLeapYearDays(StartDate, EndDate)
Exit Function
End If
Dim AnnivYrs, YrDiff As Integer
' Extract year, month, and day components
Dim startYear As Long, StartMonth As Integer, startDay As Integer
Dim endYear As Long, endMonth As Integer, endDay As Integer
startYear = Year(StartDate): StartMonth = Month(StartDate): startDay = Day(StartDate)
endYear = Year(EndDate): endMonth = Month(EndDate): endDay = Day(EndDate)
' get the number of years difference
YrDiff = endYear - startYear
Dim startBefore, endAfter As Boolean
If inclusiveStart Then
startBefore = StartMonth < Month Or _
(StartMonth = Month And startDay <= Day)
Else
startBefore = StartMonth < Month Or _
(StartMonth = Month And startDay < Day)
End If
If inclusiveEnd Then
endAfter = endMonth > Month Or _
(endMonth = Month And endDay >= Day)
Else
endAfter = endMonth > Month Or _
(endMonth = Month And endDay > 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 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}