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


' 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

 

 

Created by JBaker. Last Modification: Thursday January 30, 2020 13:01:32 GMT by JBaker.

Developer