[VBA] Datediff avec prise en compte des WE et/ou des jours ouvrés ?

Recherche :

Mot : Pseudo : Filtrer
Bas de page
Auteur	Sujet : [VBA] Datediff avec prise en compte des WE et/ou des jours ouvrés ?

Odissine

Hello tout le monde,

Je galère pour trouver un moyen de calculer la différence en jour/heures/minutes entre deux dates mais sans tenir compte par exemple des heures fermées et des WE.
Ex.
Vendredi 17 janvier @ 16:00 > Lundi 20 janvier @ 09:00
Je devrais obtenir : 0j 3h 00m car par ex les heures ouvrées sont comprises entre 8h et 18h et fermé le WE !
Actuellement si je fais le calcul j'obtiens 2j 17h ...

J'ai trouvé une fonction qui me permet de récupérer le nombre de jours entre deux dates sans tenir compte des WE ... mais ca ne répond pas a mon besoin de prendre en compte uniquement les heures ouvrées

Code :

Function BusinessDateDiff(ByVal StartDate As Date, ByVal EndDate As Date, _
Optional ByVal SaturdayIsHoliday As Boolean = True) As Long
Dim incr As Date
' ensure we don't take time part into account
StartDate = Int(StartDate)
EndDate = Int(EndDate)
' incr can be +1 or -1
If StartDate < EndDate Then incr = 1 Else incr = -1
Do Until StartDate = EndDate
' skip to previous or next day
StartDate = StartDate + incr
If Weekday(StartDate) <> vbSunday And (Weekday(StartDate) <> vbSaturday _
Or Not SaturdayIsHoliday) Then
' if it's a weekday add/subtract one to the result
BusinessDateDiff = BusinessDateDiff + incr
End If
Loop
' when the loop is exited the function name
' contains the correct result
End Function

Si vous avez une idée ou des pistes de reflexions je suis preneur !
Merci pour votre aide !

Publicité

patrice33740

Avec la réponse, c'est facile.

Bonjour,

Une proposition :

Code :

Option Explicit
Sub Test()
'
Dim hreDebOuvert As Date
Dim hreFinOuvert As Date
Dim datHreDeb As Date
Dim datHreFin As Date
Dim hreDeb As Date
Dim hreFin As Date
Dim datDeb As Date
Dim datFin As Date
Dim hreDif As Date
Dim nbrJrs As Long
Dim noJDeb As Integer
Dim noJFin As Integer
Dim nbrSem As Integer
Dim result As String
' Heures ouvrées
hreDebOuvert = #8:00:00 AM#
hreFinOuvert = #6:00:00 PM#
' Période concernée
datHreDeb = #1/17/2020 4:00:00 PM#
datHreFin = #1/20/2020 9:00:00 AM#
' Séparer dates et heures
datDeb = Int(datHreDeb)
datFin = Int(datHreFin)
hreDeb = datHreDeb - datDeb
hreFin = datHreFin - datFin
' Contrôle dates période
If datHreFin < datHreDeb Then
MsgBox "La fin de la période doit être supérieure ou égale au début de la période", vbCritical
Exit Sub
End If
noJDeb = (datDeb + 5) Mod 7
noJFin = (datFin + 5) Mod 7
If noJDeb > 4 Or noJFin > 4 Then
MsgBox "Le début et la fin de période doit être pendant les heures ouvrées", vbCritical
Exit Sub
End If
' Reliquat d'heures
If hreDeb > hreFin Then
hreDif = hreFinOuvert - hreDeb
hreDeb = hreDebOuvert
datDeb = datDeb + 1
End If
hreDif = hreDif + hreFin - hreDebOuvert
' Nombre de semaines
nbrJrs = datFin - datDeb
nbrSem = Int(nbrJrs / 7)
' Reliquat jours
noJDeb = (datDeb + 5) Mod 7
nbrJrs = nbrJrs Mod 7
If noJDeb + nbrJrs > 4 Then nbrJrs = nbrJrs - 2 'WE
nbrJrs = nbrJrs + 5 * nbrSem
' Résultat
result = nbrJrs & " j. " & Hour(hreDif) & " h. " & Minute(hreDif) & " min."
MsgBox Format(datHreDeb, "ddd dd mmm yyyy" ) & vbCrLf & _
Format(datHreFin, "ddd dd mmm yyyy" ) & vbCrLf & _
result
End Sub

Ne faudrait-il pas aussi tenir compte des jours fériés ?

---------------
Cordialement, Patrice

FORUM HardWare.fr

Programmation

VB/VBA/VBS

[VBA] Datediff avec prise en compte des WE et/ou des jours ouvrés ?

Sujets relatifs
Excel VBA : fonction indiquant #value au démarrage	VBA Word et Sendkeys
VBA Excel, TextBox qui ne fonctionne pas.	VBA msgbox?
Python 3.7.3 arriver à prendre en compte openSSL	pb script VBA sous Word pour export feuilles - laisse 1 page
VBA - Erreur Exécution	[SQL] Double compte sur 2 tables en 1 requete [résolu]
[VB/VBA/VBS] Problème script pour exécuter des programmes	Checkbox et VBA
Plus de sujets relatifs à : [VBA] Datediff avec prise en compte des WE et/ou des jours ouvrés ?

Page générée en 0.044 secondes