Carte du site
 Remerciements
 Netiquette
 Bugs
 Tables
 Requêtes
 Formulaires
 États (rapports)
 Modules
 APIs
 Chaînes
 Date/Time
 Général
 Ressources
 Téléchargeables

 Termes d'usage

DateTime: Arithmétique sur les jours, en VBA

Author(s)
Ken Getz

--- Soumis par Ken Getz---

Arithmétique sur les jours, en VBA

Ni VBA, ni Access ne fournit quelque support pour travailler avec les jours ouvrables (généralement, du lundi au vendredi).

Le bouquin VBA Developers Handbook (Sybex) contient plusieurs fonctions qui retournent le prochain jour ouvrable, ou qui trouvent le dernier jour d'un mois, par exemple. Pour régler le cas des jours fériés, la fonction  SkipHolidays  accepte un recordset comme argument, recordset qui contient toutes les dates considérées comme fériées.

Pour accroître la facilité d'utilisation, cette fonction fut réécrite pour accepter un vecteur, un peu comme la fonction  WorkDay d'Excel.

Voir la fin du code fourni pour personnaliser les journées non ouvrables répétitives, les jours de "la fin de semaine" si vous préférez.

' ********* Code Start **************
'
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
'

Public Function dhAddWorkDaysA(lngDays As Long, _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant) As Date
    ' Ajouter le nombre de jours ouvrables
    ' à la date spécifiée.
    
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' In:
    '   lngDays:
    '       Nombre de jours ouvrables à ajouter.
    '   dtmDate:
    '       Date à laquelle on ajoute. Utilise aujourd'hui
    '       si aucune date n'est fournie.
    '   adtmDates (Optionel):
    '       Vecteur de dates de congées. Peut également être
    '       une seule date, au besoin.
    ' Out:
    '   Return Value:
    '       La date du jour ouvrable après que le nombre de jours ouvrables
    '       spédifié se soit écoulé depuis le départ, incluant les jours fériés.
    ' Example:
    '   dhAddWorkDaysA(10, #2/9/2000#, Array(#2/16/2000#, #2/17/2000#))
    '   retourne #2/25/2000#, soit la date après 10 ouvrables
    '   après le 2/9/2000, considérant que les 2/16 et 2/17 sont fériés
    '   (pour illustration simplement).
    
    ' Did the caller pass in a date? If not, use
    ' the current date.
    Dim lngCount As Long
    Dim dtmTemp As Date
    
    If dtmDate = 0 Then
        dtmDate = Date
    End If
    
    dtmTemp = dtmDate
    For lngCount = 1 To lngDays
        dtmTemp = dhNextWorkdayA(dtmTemp, adtmDates)
    Next lngCount
    dhAddWorkDaysA = dtmTemp
End Function

Public Function dhNextWorkdayA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date
    
    ' Return the next working day after the specified date.
    
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' Requires:
    '   SkipHolidays
    '   IsWeekend
    
    ' In:
    '   dtmDate:
    '       date on which to start looking.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' Out:
    '   Return Value:
    '       The date of the next working day, taking
    '       into account weekends and holidays.
    ' Example:
    '   ' Find the next working date after 5/30/97
    '   dtmDate = dhNextWorkdayA(#5/23/1997#, #5/26/97#)
    '   ' dtmDate should be 5/27/97, because 5/26/97 is Memorial day.
    
    ' Did the caller pass in a date? If not, use
    ' the current date.
    If dtmDate = 0 Then
        dtmDate = Date
    End If
    
    dhNextWorkdayA = SkipHolidaysA(adtmDates, dtmDate + 1, 1)
End Function

Public Function dhPreviousWorkdayA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date
    
    ' Return the previous working day before the specified date.
    
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' Requires:
    '   SkipHolidays
    '   IsWeekend
    
    ' In:
    '   dtmDate:
    '       date on which to start looking.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' Out:
    '   Return Value:
    '       The date of the previous working day, taking
    '       into account weekends and holidays.
    ' Example:
    '   ' Find the next working date before 1/1/2000
    
    '   dtmDate = dhPreviousWorkdayA(#1/1/2000#, Array(#12/31/1999#, #1/1/2000#))
    '   ' dtmDate should be 12/30/1999, because of the New Year's holidays.
    
    ' Did the caller pass in a date? If not, use
    ' the current date.
    If dtmDate = 0 Then
        dtmDate = Date
    End If
    
    dhPreviousWorkdayA = SkipHolidaysA(adtmDates, dtmDate - 1, -1)
End Function

Public Function dhFirstWorkdayInMonthA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date
    
    ' Retourne le premier jour ouvrable du mois spécifié.
    
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' Requires:
    '   SkipHolidays
    '   IsWeekend
    
    ' In:
    '   dtmDate:
    '       date within the month of interest.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' Out:
    '   Return Value:
    '       The date of the first working day in the month, taking
    '       into account weekends and holidays.
    ' Example:
    '   ' Find the first working day in 1999
    '   dtmDate = dhFirstWorkdayInMonthA(#1/1/1999#, #1/1/1999#)
    
    Dim dtmTemp As Date
    
    ' Did the caller pass in a date? If not, use
    ' the current date.
    If dtmDate = 0 Then
        dtmDate = Date
    End If
    
    dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate), 1)
    dhFirstWorkdayInMonthA = SkipHolidaysA(adtmDates, dtmTemp, 1)
End Function

Public Function dhLastWorkdayInMonthA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date
    
    ' Retuurne le dernier jour ouvrable du mois spédifié.
    
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' Requires:
    '   SkipHolidays
    '   IsWeekend
    
    ' In:
    '   dtmDate:
    '       date within the month of interest.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' Out:
    '   Return Value:
    '       The date of the last working day in the month, taking
    '       into account weekends and holidays.
    ' Example:
    '   ' Find the last working day in 1999
    '   dtmDate = dhLastWorkdayInMonthA(#12/1/1999#, #12/31/1999#)
    
    Dim dtmTemp As Date
    
    ' Did the caller pass in a date? If not, use
    ' the current date.
    If dtmDate = 0 Then
        dtmDate = Date
    End If
    
    dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
    dhLastWorkdayInMonthA = SkipHolidaysA(adtmDates, dtmTemp, -1)
End Function

Public Function dhCountWorkdaysA(ByVal dtmStart As Date, ByVal dtmEnd As Date, _
 Optional adtmDates As Variant = Empty) _
 As Integer

    ' Calcule le nombre de jours ouvrables (éliminant fin de semaine et
    ' jours fériés) entre deux dates.
    
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' Requires:
    '   SkipHolidays
    '   CountHolidays
    '   IsWeekend
    
    ' In:
    '   dtmStart:
    '       Date du début (inclusivement)
    '   dtmEnd:
    '       Date de fin  (inclusivement)
    '       (Les dates seront échangées si dans le mauvais ordre)
    '   adtmDates (Optionel):
    '       Vecteur contenant les jours fériés, peut ne contenir qu'un seul
    '       jour.
    ' Out:
    '   Return Value:
    '       Nombre de jours ouvrables entre les deux dates (inclusivement).
    ' Exemple:
    '   Debug.Print dhCountWorkdaysA(#7/2/2000#, #7/5/2000#, _
    '    Array(#1/1/2000#, #7/4/2000#))
    '
    '   retourne 2, car 7/2/2000 est un dimanche, 7/4/2000 est férié,
    '   laissant que  7/3 et 7/5 comme jours ouvrables.
    
    Dim intDays As Integer
    Dim dtmTemp As Date
    Dim intSubtract As Integer
    
    ' Swap the dates if necessary.>
    If dtmEnd < dtmStart Then
        dtmTemp = dtmStart
        dtmStart = dtmEnd
        dtmEnd = dtmTemp
    End If
    
    ' Get the start and end dates to be weekdays.
    dtmStart = SkipHolidaysA(adtmDates, dtmStart, 1)
    dtmEnd = SkipHolidaysA(adtmDates, dtmEnd, -1)
    If dtmStart > dtmEnd Then
        ' Sorry, no Workdays to be had. Just return 0.
        dhCountWorkdaysA = 0
    Else
        intDays = dtmEnd - dtmStart + 1
        
        ' Subtract off weekend days.  Do this by figuring out how
        ' many calendar weeks there are between the dates, and
        ' multiplying the difference by two (because there are two
        ' weekend days for each week). That is, if the difference
        ' is 0, the two days are in the same week. If the
        ' difference is 1, then we have two weekend days.
        intSubtract = (DateDiff("ww", dtmStart, dtmEnd) * 2)
        
        ' The answer to our quest is all the weekdays, minus any
        ' holidays found in the table.
        intSubtract = intSubtract + _
         CountHolidaysA(adtmDates, dtmStart, dtmEnd)
        
        dhCountWorkdaysA = intDays - intSubtract
    End If
End Function

Private Function CountHolidaysA( _
adtmDates As Variant, _
dtmStart As Date, dtmEnd As Date) As Long

    ' Le nombre de jours fériés entre deux dates.
    '
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' Required by:
    '   dhCountWorkdays
    
    ' Requires:
    '   IsWeekend
    
    
    Dim lngItem As Long
    Dim lngCount As Long
    Dim blnFound As Long
    Dim dtmTemp As Date
    
    On Error GoTo HandleErr
    lngCount = 0
    Select Case VarType(adtmDates)
        Case vbArray + vbDate, vbArray + vbVariant
            ' You got an array of variants, or of dates.
            ' Loop through, looking for non-weekend values
            ' between the two endpoints.
            For lngItem = LBound(adtmDates) To UBound(adtmDates)
                dtmTemp = adtmDates(lngItem)
                If dtmTemp >= dtmStart And dtmTemp <= dtmEnd Then
                    If Not IsWeekend(dtmTemp) Then
                        lngCount = lngCount + 1
                    End If
                End If
            Next lngItem
        Case vbDate
            ' You got one date. So see if it's a non-weekend
            ' date between the two endpoints.
            If adtmDates >= dtmStart And adtmDates <= dtmEnd Then
                If Not IsWeekend(adtmDates) Then
                    lngCount = 1
                End If
            End If
    End Select

ExitHere:
    CountHolidaysA = lngCount
    Exit Function
    
HandleErr:
    ' No matter what the error, just
    ' return without complaining.
    ' The worst that could happen is that the code
    ' include a holiday as a real day, even if
    ' it's in the table.
    Resume ExitHere
End Function

Private Function FindItemInArray(varItemToFind As Variant, _
avarItemsToSearch As Variant) As Boolean
    Dim lngItem As Long
    
    On Error GoTo HandleErrors
    
    For lngItem = LBound(avarItemsToSearch) To UBound(avarItemsToSearch)
        If avarItemsToSearch(lngItem) = varItemToFind Then
            FindItemInArray = True
            GoTo ExitHere
        End If
    Next lngItem
    
ExitHere:
    Exit Function
    
HandleErrors:
    ' Do nothing at all.
    ' Return False.
    Resume ExitHere
End Function

Private Function IsWeekend(dtmTemp As Variant) As Boolean
    ' Si les jours de fins de semaine ne sont 
    ' pas le dimanche (jour 1) et le samedi (jour 7),
    ' changer le code de cette fonction pour retourner True pour les jours
    ' que vous considérez comme les jours de fin de semaine.
    
    ' Modified from code in "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' Required by:
    '   SkipHolidays
    '   dhFirstWorkdayInMonth
    '   dbLastWorkdayInMonth
    '   dhNextWorkday
    '   dhPreviousWorkday
    '   dhCountWorkdays
    
    If VarType(dtmTemp) = vbDate Then
        Select Case Weekday(dtmTemp)
            Case vbSaturday, vbSunday
                IsWeekend = True
            Case Else
                IsWeekend = False
        End Select
    End If
End Function

Private Function SkipHolidaysA( _
adtmDates As Variant, _
dtmTemp As Date, intIncrement As Integer) As Date
    ' Skip weekend days, and holidays in the array referred to by adtmDates.
    ' Return dtmTemp + as many days as it takes to get to a day that's not
    ' a holiday or weekend.
    
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.
    
    ' Required by:
    '   dhFirstWorkdayInMonthA
    '   dbLastWorkdayInMonthA
    '   dhNextWorkdayA
    '   dhPreviousWorkdayA
    '   dhCountWorkdaysA
    
    ' Requires:
    '   IsWeekend
    
    Dim strCriteria As String
    Dim strFieldName As String
    Dim lngItem As Long
    Dim blnFound As Boolean
    
    On Error GoTo HandleErrors
    
    ' Move up to the first Monday/last Friday, if the first/last
    ' of the month was a weekend date. Then skip holidays.
    ' Repeat this entire process until you get to a weekday.
    ' Unless adtmDates an item for every day in the year (!)
    ' this should finally converge on a weekday.
    
    Do
        Do While IsWeekend(dtmTemp)
            dtmTemp = dtmTemp + intIncrement
        Loop
        Select Case VarType(adtmDates)
            Case vbArray + vbDate, vbArray + vbVariant
                Do
                    blnFound = FindItemInArray(dtmTemp, adtmDates)
                    If blnFound Then
                        dtmTemp = dtmTemp + intIncrement
                    End If
                Loop Until Not blnFound
            Case vbDate
                If dtmTemp = adtmDates Then
                    dtmTemp = dtmTemp + intIncrement
                End If
        End Select
    Loop Until Not IsWeekend(dtmTemp)
    
ExitHere:
    SkipHolidaysA = dtmTemp
    Exit Function
    
HandleErrors:
    ' No matter what the error, just
    ' return without complaining.
    ' The worst that could happen is that we
    ' include a holiday as a real day, even if
    ' it's in the array.
    Resume ExitHere
End Function
' ********* Code End **************

© 1998-2001, Dev Ashish, All rights reserved. Optimized for Microsoft Internet Explorer