Loading...
 
JoiWiki » Developer » MS Office » VBA Snippets » VBA Date Functions VBA Date Functions

VBA Date Functions

 

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

 

 

Created by JBaker. Last Modification: Monday February 26, 2024 21:26:49 GMT by JBaker.

Developer