Difference entre 2 date (avec heure) en jours ouvrés

**imaril** · 28/01/2010, 10h19

Bonjour,

Pour le travail, je dois réaliser une macro qui va faire un tableau de bord qui récapitulera le nombre de projet rendu dans les délais (nos engagement vis à vis de la société pour laquelle on travail).
Ces objectif varie suivant le niveau de priorité des projet.
Mais les jours travailler ainsi que les heures de travail varient suivant les priorités. je vous donne un exemple :

priorité 1 : 24H/24 et 6j/7
priorité 3 : 9h-18H et 5J/7

il faut donc que je trouve la différence entre 2 date en prenant compte de ces paramètres.
Vu que ce ne sont pas vraiment de "vrai" jours ouvré, je ne peux pas utiliser la commande NB.Jours.Ouvres,

je trouve pas de solution qui prenne en compte tout ca et les jours fériés

EDIT
Voici la solution :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As String
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte
Dim hr1 As Double, hr2 As Double
Dim Res As Double
 
If Priorite = "p1" Then
    FirstDay = vbSunday
    Offs = 1
    hr = 24
    hr1 = 24 - ((Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60))
ElseIf Priorite = "p2" Then
    FirstDay = vbSaturday
    Offs = 2
    hr = 9
    If DateDiff("d", dte1, dte2) = 0 Then
        hr1 = 9 - ((Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60))
    Else
        If Not ferie(dte1) Then hr1 = (Hour(dte1) + Minute(dte1) / 60) - 9
        If Not ferie(dte2) Then hr2 = 18 - (Hour(dte2) + Minute(dte2) / 60)
    End If
End If
 
For i = 0 To DateDiff("d", dte1, dte2)
    If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), FirstDay) > Offs Then nbjr = nbjr + 1
Next i
Res = nbjr * hr - hr1 - hr2
If Int(Res) = 0 Then
    NbHeures = Format(Int(Res * 60), "00") & "min"
Else
    NbHeures = Format(Int(Res), "00") & "h:" & Format(Int((Res - Int(Res)) * 60), "00") & "min"
End If
End Function

**imaril** · 28/01/2010, 10h55

Alors en fouinan un peu sur le net j'ai trouvé :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
 
    * function nbjourouvrable(datdeb,datfin)
    * if datdeb="" or datfin="" then exit function
    *
    * nbjourtot = DateDiff("d",datdeb,datfin) + 1
    *
    * for i=1 to nbjourtot
    *
    * if ferie(datdeb) then
    * nbjourtot = nbjourtot - 1
    * end if
    *
    * datdeb=DateAdd("d",1,datdeb)
    *
    * next
    *
    * nbjourouvrable=nbjourtot
    *
    * End function
    *
    * function ferie(Jour)
    * if jour="" then exit function
    * Dim JJ,AA
    * Dim NbOr, Epacte
    * Dim PLune, Paques, Ascension, Pentecote
    *
    * JJ = Day(Jour)
    * mm = Month(Jour)
    * AA = Year(Jour)
    *
    * If JJ = 1 And mm = 1 Then ferie = True: Exit Function '1 Janvier
    * If JJ = 1 And mm = 5 Then ferie = True: Exit Function '1 Mai
    * If JJ = 8 And mm = 5 Then ferie = True: Exit Function '8 Mai
    * If JJ = 14 And mm = 7 Then ferie = True: Exit Function '14 Juillet
    * If JJ = 15 And mm = 8 Then ferie = True: Exit Function '15 Août
    * If JJ = 1 And mm = 11 Then ferie = True: Exit Function '1 Novembre
    * If JJ = 11 And mm = 11 Then ferie = True: Exit Function '11 Novembre
    * If JJ = 25 And mm = 12 Then ferie = True: Exit Function '25 Décembre
    *
    * NbOr = (AA Mod 19) + 1
    * Epacte = (11 * NbOr - (3 + Int((2 + Int(AA / 100)) * 3 / 7))) Mod 30
    * PLune = CDate("19/04/" & AA) - ((Epacte + 6) Mod 30)
    * If Epacte = 24 Then PLune = PLune - 1
    * If Epacte = 25 And (AA >= 1900 And AA < 2000) Then PLune = PLune - 1
    *
    * Paques = PLune - Weekday(PLune) + vbMonday + 7 'Paques
    * If JJ = Day(Paques) And mm = Month(Paques) Then ferie=true : Exit Function
    *
    * Ascension = Paques + 38 'Ascension
    * If JJ = Day(Ascension) And mm = Month(Ascension) Then ferie=true : Exit Function
    *
    * Pentecote = Ascension + 11 'Pentecote
    * If JJ = Day(Pentecote) And mm = Month(Pentecote) Then ferie=true : Exit Function
    * ferie = False
    * Dim numjour
    * numjour=weekday(jour,vbmonday) 'fixe à 6 et 7 la valeur du samedi & dimanche
    * if numjour=6 or numjour=7 then ferie=true : Exit function
    * End function

ce code compte bien la différence avec les jours fériés et tout mais ne prend pas en compte les heures avez vous une idée de comment prendre en compte les heure travaillées?

**mercatog** · 28/01/2010, 12h54

Bonjour,
ci joint petit essai (malheureusement ne prends en compte les jours fériés)
Priorité 1: (p1) 24h/jour sauf le dimanche
Priorité 2: (p2) 8h/jour sauf samedi et dimanche

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As Integer
 
Dim nbs As Integer, nbjr As Integer, nbhr As Integer
 
If Priorite = "p1" Then
    nbjr = DateDiff("d", dte1, dte2, vbSunday, vbFirstJan1)
    nbs = DateDiff("ww", dte1, dte2, vbSunday, vbFirstJan1)
    NbHeures = (nbjr - nbs + 1) * 24
ElseIf Priorite = "p2" Then
    nbjr = DateDiff("d", dte1, dte2, vbSaturday, vbFirstJan1)
    nbs = DateDiff("ww", dte1, dte2, vbSaturday, vbFirstJan1)
    If Weekday(dte2, vbSaturday) = 1 Then
        NbHeures = (nbjr - 2 * nbs + 2) * 8
    Else
        NbHeures = (nbjr - 2 * nbs + 1) * 8
    End If
End If
 
End Function

**imaril** · 28/01/2010, 13h27

Merci mercatog pour ton code, je pense pouvoir trouver ou faire une fonction qui va me dire si il y a un jour férié dans l'intervalle des 2 dates ce qui compèterais ton code, je cherche ca et je vous tiens au courant
tout autre solutions sont aussi les bienvenues

Edit 1: en lisant ton code, je me suis poser une question, l'heure de dépos ou de rendu du projet (contenu dans la date jj/mm/yyyy hh:mm) n'est pas pris en compte par exemple : le projet est demandé le 18/01/2010 17:00 et est rendu le 20/01/2010 10:00 la difference est de 1jour et 2H pour une priorité 2 et le code donne : 24H soit 2H de difference

edit 2:

ne peut-on pas utiliser le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
function ferie(Jour)
     if jour="" then exit function
     Dim JJ,AA
     Dim NbOr, Epacte
     Dim PLune, Paques, Ascension, Pentecote
 
     JJ = Day(Jour)
     mm = Month(Jour)
     AA = Year(Jour)
 
     If JJ = 1 And mm = 1 Then ferie = True: Exit Function '1 Janvier
     If JJ = 1 And mm = 5 Then ferie = True: Exit Function '1 Mai
     If JJ = 8 And mm = 5 Then ferie = True: Exit Function '8 Mai
     If JJ = 14 And mm = 7 Then ferie = True: Exit Function '14 Juillet
     If JJ = 15 And mm = 8 Then ferie = True: Exit Function '15 Août
     If JJ = 1 And mm = 11 Then ferie = True: Exit Function '1 Novembre
     If JJ = 11 And mm = 11 Then ferie = True: Exit Function '11 Novembre
     If JJ = 25 And mm = 12 Then ferie = True: Exit Function '25 Décembre
 
     NbOr = (AA Mod 19) + 1
     Epacte = (11 * NbOr - (3 + Int((2 + Int(AA / 100)) * 3 / 7))) Mod 30
     PLune = CDate("19/04/" & AA) - ((Epacte + 6) Mod 30)
     If Epacte = 24 Then PLune = PLune - 1
     If Epacte = 25 And (AA >= 1900 And AA < 2000) Then PLune = PLune - 1
 
     Paques = PLune - Weekday(PLune) + vbMonday + 7 'Paques
     If JJ = Day(Paques) And mm = Month(Paques) Then ferie=true : Exit Function
 
    Ascension = Paques + 38 'Ascension
     If JJ = Day(Ascension) And mm = Month(Ascension) Then ferie=true : Exit Function
 
     Pentecote = Ascension + 11 'Pentecote
    If JJ = Day(Pentecote) And mm = Month(Pentecote) Then ferie=true : Exit Function
     ferie = False
    End function

et l'appliquer à chaque date de l'intervalle ? ou ca serais trop lourd? (tout en prenant en compte le fait que je devrai faire ce calcul pour une 50ene de dates différentes...)

**mercatog** · 28/01/2010, 14h23

Bonjour,
ci joint adaptation

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Public Function ferie(ByVal DateTest) As Boolean
Dim JJ As Integer, AA As Integer, MM As Integer
Dim NbOr As Integer, Epacte As Integer
Dim PLune As Date, Paques As Date, Ascension As Date, Pentecote As Date
 
ferie = False
If DateTest = "" Then Exit Function
 
JJ = Day(DateTest)
MM = Month(DateTest)
AA = Year(DateTest)
 
If JJ = 1 And MM = 1 Then ferie = True: Exit Function '1 Janvier
If JJ = 1 And MM = 5 Then ferie = True: Exit Function '1 Mai
If JJ = 8 And MM = 5 Then ferie = True: Exit Function '8 Mai
If JJ = 14 And MM = 7 Then ferie = True: Exit Function '14 Juillet
If JJ = 15 And MM = 8 Then ferie = True: Exit Function '15 Août
If JJ = 1 And MM = 11 Then ferie = True: Exit Function '1 Novembre
If JJ = 11 And MM = 11 Then ferie = True: Exit Function '11 Novembre
If JJ = 25 And MM = 12 Then ferie = True: Exit Function '25 Décembre
 
NbOr = (AA Mod 19) + 1
Epacte = (11 * NbOr - (3 + Int((2 + Int(AA / 100)) * 3 / 7))) Mod 30
PLune = DateAdd("d", CDate("19/04/" & AA), -((Epacte + 6) Mod 30))
If Epacte = 24 Then PLune = DateAdd("d", PLune, -1)
If Epacte = 25 And (AA >= 1900 And AA < 2000) Then PLune = DateAdd("d", PLune, -1)
 
Paques = DateAdd("d", PLune, 7 - Weekday(PLune) + vbMonday) 'Paques
If JJ = Day(Paques) And MM = Month(Paques) Then ferie = True: Exit Function
 
Ascension = DateAdd("d", Paques, 38) 'Ascension
If JJ = Day(Ascension) And MM = Month(Ascension) Then ferie = True: Exit Function
 
Pentecote = DateAdd("d", Ascension, 11) 'Pentecote
If JJ = Day(Pentecote) And MM = Month(Pentecote) Then ferie = True: Exit Function
 
End Function
 
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As Integer
Dim nbs As Integer, nbjr As Integer, nbhr As Integer
Dim i As Integer, NbJrFerie As Integer
 
 
If Priorite = "p1" Then
    For i = 0 To DateDiff("d", dte1, dte2)
        If ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), vbSunday) > 1 Then NbJrFerie = NbJrFerie + 1
    Next i
 
    nbjr = DateDiff("d", dte1, dte2, vbSunday, vbFirstJan1)
    nbs = DateDiff("ww", dte1, dte2, vbSunday, vbFirstJan1)
    NbHeures = (nbjr - nbs + 1 - NbJrFerie) * 24
ElseIf Priorite = "p2" Then
    For i = 0 To DateDiff("d", dte1, dte2)
        If ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), vbSaturday) > 2 Then NbJrFerie = NbJrFerie + 1
    Next i
 
    nbjr = DateDiff("d", dte1, dte2, vbSaturday, vbFirstJan1)
    nbs = DateDiff("ww", dte1, dte2, vbSaturday, vbFirstJan1)
    If Weekday(dte2, vbSaturday) = 1 Then
        NbHeures = (nbjr - 2 * nbs + 2 - NbJrFerie) * 8
    Else
        NbHeures = (nbjr - 2 * nbs + 1 - NbJrFerie) * 8
    End If
End If
 
End Function

**mercatog** · 28/01/2010, 14h58

ou simplement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Public Function ferie(ByVal DateTest) As Boolean
Dim JJ As Integer, AA As Integer, MM As Integer
Dim NbOr As Integer, Epacte As Integer
Dim PLune As Date, Paques As Date, Ascension As Date, Pentecote As Date
 
ferie = False
If DateTest = "" Then Exit Function
 
JJ = Day(DateTest)
MM = Month(DateTest)
AA = Year(DateTest)
 
If JJ = 1 And MM = 1 Then ferie = True: Exit Function '1 Janvier
If JJ = 1 And MM = 5 Then ferie = True: Exit Function '1 Mai
If JJ = 8 And MM = 5 Then ferie = True: Exit Function '8 Mai
If JJ = 14 And MM = 7 Then ferie = True: Exit Function '14 Juillet
If JJ = 15 And MM = 8 Then ferie = True: Exit Function '15 Août
If JJ = 1 And MM = 11 Then ferie = True: Exit Function '1 Novembre
If JJ = 11 And MM = 11 Then ferie = True: Exit Function '11 Novembre
If JJ = 25 And MM = 12 Then ferie = True: Exit Function '25 Décembre
 
NbOr = (AA Mod 19) + 1
Epacte = (11 * NbOr - (3 + Int((2 + Int(AA / 100)) * 3 / 7))) Mod 30
PLune = DateAdd("d", CDate("19/04/" & AA), -((Epacte + 6) Mod 30))
If Epacte = 24 Then PLune = DateAdd("d", PLune, -1)
If Epacte = 25 And (AA >= 1900 And AA < 2000) Then PLune = DateAdd("d", PLune, -1)
 
Paques = DateAdd("d", PLune, 7 - Weekday(PLune) + vbMonday) 'Paques
If JJ = Day(Paques) And MM = Month(Paques) Then ferie = True: Exit Function
 
Ascension = DateAdd("d", Paques, 38) 'Ascension
If JJ = Day(Ascension) And MM = Month(Ascension) Then ferie = True: Exit Function
 
Pentecote = DateAdd("d", Ascension, 11) 'Pentecote
If JJ = Day(Pentecote) And MM = Month(Pentecote) Then ferie = True: Exit Function
 
End Function
 
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As Integer
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte
 
If Priorite = "p1" Then
    FirstDay = vbSunday
    Offs = 1
    hr = 24
ElseIf Priorite = "p2" Then
    FirstDay = vbSaturday
    Offs = 2
    hr = 8
End If
 
For i = 0 To DateDiff("d", dte1, dte2)
    If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), FirstDay) > Offs Then nbjr = nbjr + 1
Next i
NbHeures = nbjr * hr
End Function

**imaril** · 28/01/2010, 15h28

je te remerci beaucoup, ce code conviens parfaitement pour les priorité avec un 24/24 mais avec des horaires du style 9H-18H le code plante je cherche une solution pour prendre en compte le gap 18H-->9H ( le lendemain)

**mercatog** · 28/01/2010, 15h54

Si j'avais bien compris,
priorité 1: 24 heures par jour toute la semaine sauf le dimanche et les jours fériés
priorité 2: 8 heures par jour toute la semaine sauf le samedi et dimanche et les jours fériés

si c'est ça?

**imaril** · 28/01/2010, 16h07

oui c'est bien ca, mais il y a des horaire d'ouverture du site ( de 9H à 18H) pour les priorité 2 donc si on reçoit le dossier à 17H et qu'on le rend le lendemain à 11H on aura mis que 3H pour résoudre ce dossier et si les conditions sont : moins de 4H, c'est bon.c'est ca la subtilité ^^

edit :
j'ai commencer un code un peu brutal pour résoudre le probleme des heures dans le cas du 9H-18H:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
 
Function diff(priorite As String, date1 As Date, date2 As Date) As Boolean
Dim T1 As Long
Dim T2 As Long
Dim d1 As Date
Dim d2 As Date
limite = 60
Select Case DateDiff("d", date1, date2, vbSaturday, vbFirstJan1)
    Case 0
        If DateDiff("n", date1, date2) <= limite Then
            diff = True
        Else
            diff = False
        End If
    Case 1
        d1 = Hour(date1) & ":" & Minute(date1)
        d2 = Hour(date2) & ":" & Minute(date2)
        If d2 < d1 Then
            T1 = DateDiff("n", date1, Day(date1) & "/" & Month(date1) & "/" & Year(date1) & " 18:00")
            T2 = DateDiff("n", Day(date2) & "/" & Month(date2) & "/" & Year(date2) & " 09:00", date2)
            If T1 + T2 <= limite Then
                diff = True
            Else
                diff = False
            End If
        Else
            T1 = 8 * 60
            T2 = DateDiff("n", Day(date2) & "/" & Month(date2) & "/" & Year(date2) & " " & d1, date2)
            If T1 + T2 <= limite Then
                diff = True
            Else
                diff = False
            End If
        End If
End Select

avec apres un case >1 ou on utilise le compteur de jours ouvre plus mon systeme barbar pour les heures

**mercatog** · 28/01/2010, 19h54

Si je comprends bien, le premier jour et le dernier qui poseraient problème
ci-joint modification

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As Integer
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte, hr1 As Byte, hr2 As Byte
 
If Priorite = "p1" Then
    FirstDay = vbSunday
    Offs = 1
    hr = 24
ElseIf Priorite = "p2" Then
    FirstDay = vbSaturday
    Offs = 2
    hr = 8
    If Not ferie(dte1) Then hr1 = 18 - Hour(dte1)
    If Not ferie(dte2) Then hr2 = Hour(dte2) - 9
End If
 
For i = 1 To DateDiff("d", dte1, dte2) - 1
    If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), FirstDay) > Offs Then nbjr = nbjr + 1
Next i
 
NbHeures = nbjr * hr + hr1 + hr2
End Function

**imaril** · 29/01/2010, 10h20

ah ouais ton code est nettement plus propre que le mien...
Il y a 2 petit bug cependant, je vais les corriger (si j'y arrive)
ces bug : si on est la même journee
exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub test()
Dim d1 As Date
Dim d2 As Date
 
d1 = "18/01/2010 16:00 "
d2 = "18/01/2010 17:00"
MsgBox NbHeures("p2", d1, d2)
End Sub

ressort 10H au lieu de 1H

2eme bug : le code ne prend pas en compte les minutes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub test()
Dim d1 As Date
Dim d2 As Date
 
d1 = "18/01/2010 16:25 "
d2 = "19/01/2010 16:30"
d3 = "18/01/2010 16:30 "
d4 = "19/01/2010 16:25"
MsgBox NbHeures("p2", d1, d2)
MsgBox NbHeures("p2", d3, d4)
End Sub

Les 2 execution sortiront 9H mais l'une sera dans les temps et pas l'autre..

**mercatog** · 29/01/2010, 11h11

Bonjour,
doucement on arrivera
ci-joint code modifié
Edit: pour p1 c'était 9h/jour
j'ai adapté la fonction (en sortie string XXh:YYmin)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As String
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte
Dim hr1 As Double, hr2 As Double
Dim Res As Double
 
If Priorite = "p1" Then
    FirstDay = vbSunday
    Offs = 1
    hr = 24
    hr1 = 24
    hr2 = 24
ElseIf Priorite = "p2" Then
    FirstDay = vbSaturday
    Offs = 2
    hr = 9
    If DateDiff("d", dte1, dte2) = 0 Then
        hr1 = (Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60)
        hr2 = 0
    Else
        If Not ferie(dte1) Then hr1 = 18 - (Hour(dte1) + Minute(dte1) / 60)
        If Not ferie(dte2) Then hr2 = (Hour(dte2) + Minute(dte2) / 60) - 9
    End If
End If
 
For i = 1 To DateDiff("d", dte1, dte2) - 1
    If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), FirstDay) > Offs Then nbjr = nbjr + 1
Next i
Res = nbjr * hr + hr1 + hr2
If Int(Res) = 0 Then
    NbHeures = Format(Int(Res * 60), "00") & "min"
Else
    NbHeures = Format(Int(Res), "00") & "h:" & Format(Int((Res - Int(Res)) * 60), "00") & "min"
End If
End Function

**imaril** · 29/01/2010, 11h31

Toujours plus propre les tiens que les mien xD ci-join mon code xD :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
 
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As Double
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte, hr1 As Long, hr2 As Long
 
If Priorite = "p1" Then
    FirstDay = vbSunday
    Offs = 1
    hr = 24
    If DateDiff("d", dte1, dte2) = 0 Then
        hr1 = DateDiff("n", dte1, dte2)
        hr2 = 0
    End If
ElseIf Priorite = "p2" Then
    FirstDay = vbSaturday
    Offs = 2
    hr = 8
    If DateDiff("d", dte1, dte2) = 0 Then
        hr1 = DateDiff("n", dte1, dte2)
        hr2 = 0
    Else
        If Not ferie(dte1) Then hr1 = DateDiff("n", dte1, Day(dte1) & "/" & Month(dte1) & "/" & Year(dte1) & " 18:00")
        If Not ferie(dte2) Then hr2 = DateDiff("n", Day(dte2) & "/" & Month(dte2) & "/" & Year(dte2) & " 09:00", dte2)
    End If
End If
 
For i = 1 To DateDiff("d", dte1, dte2) - 1
    If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), FirstDay) > Offs Then nbjr = nbjr + 1
Next i
 
NbHeures = (nbjr * hr * 60 + hr1 + hr2) / 60
End Function

edit :
le :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
    hr1 = 24
    hr2 = 24

que vien-t-il faire ici ? car dans le cas de 2 jours consecutil il sort 48H de décalage au lieu de 24

**imaril** · 29/01/2010, 11h53

Ma derniere version qui je pense fonctionne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As String
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte
Dim hr1 As Double, hr2 As Double
Dim Res As Double
 
If Priorite = "p1" Then
    FirstDay = vbSunday
    Offs = 1
    hr = 24
    If DateDiff("d", dte1, dte2) = 0 Then
        hr1 = (Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60)
        hr2 = 0
    Else
        hr1 = 24
        hr2 = (Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60)
    End If
ElseIf Priorite = "p2" Then
    FirstDay = vbSaturday
    Offs = 2
    hr = 9
    If DateDiff("d", dte1, dte2) = 0 Then
        hr1 = (Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60)
        hr2 = 0
    Else
        If Not ferie(dte1) Then hr1 = 18 - (Hour(dte1) + Minute(dte1) / 60)
        If Not ferie(dte2) Then hr2 = (Hour(dte2) + Minute(dte2) / 60) - 9
    End If
End If
 
For i = 1 To DateDiff("d", dte1, dte2) - 1
    If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), FirstDay) > Offs Then nbjr = nbjr + 1
Next i
Res = nbjr * hr + hr1 + hr2
If Int(Res) = 0 Then
    NbHeures = Format(Int(Res * 60), "00") & "min"
Else
    NbHeures = Format(Int(Res), "00") & "h:" & Format(Int((Res - Int(Res)) * 60), "00") & "min"
End If
End Function

si tu voix un bug dis moi ou une solution plus propre
cet apres-midi, je vais réaliser ma phase de test avec toutes les dates bizarres

**mercatog** · 29/01/2010, 12h11

On continu les essais

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As String
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte
Dim hr1 As Double, hr2 As Double
Dim Res As Double
 
If Priorite = "p1" Then
    FirstDay = vbSunday
    Offs = 1
    hr = 24
ElseIf Priorite = "p2" Then
    FirstDay = vbSaturday
    Offs = 2
    hr = 9
    If DateDiff("d", dte1, dte2) = 0 Then
        hr1 = 9 - ((Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60))
        hr2 = 0
    Else
        If Not ferie(dte1) Then hr1 = (Hour(dte1) + Minute(dte1) / 60) - 9
        If Not ferie(dte2) Then hr2 = 18 - (Hour(dte2) + Minute(dte2) / 60)
    End If
End If
 
For i = 0 To DateDiff("d", dte1, dte2)
    If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), FirstDay) > Offs Then nbjr = nbjr + 1
Next i
Res = nbjr * hr - hr1 - hr2
If Int(Res) = 0 Then
    NbHeures = Format(Int(Res * 60), "00") & "min"
Else
    NbHeures = Format(Int(Res), "00") & "h:" & Format(Int((Res - Int(Res)) * 60), "00") & "min"
End If
End Function

supposons pour p1: d1=18/01/2010 et d2=19/01/2010
le résultat est 48heures: 24heures/jours * 2jours

Edit:
Les 2 variantes donnent le même résultat

**imaril** · 29/01/2010, 12h19

Ta fonction ne prend pas en compte les cas :
18/01/2010 16:00
19/01/2010 15:00
==> 48H au lieu de 23
mais ne te prend plus la tête sur ca, la dernière version que j'ai poster (juste au dessu) a l'air de fonctionner je vais faire mes test cet aprèm et je te tiendrais au courant

mais tout de même ÉNORME merci d'avoir passer du temps a m'aider c'est très gentil de ta part

ps: si tu vois des abération dans le code dit le moi

ps2 encore merci

**mercatog** · 29/01/2010, 12h27

Effectivement, je n'avais pas traité le p1 comme il faut

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As String
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte
Dim hr1 As Double, hr2 As Double
Dim Res As Double
 
If Priorite = "p1" Then
    FirstDay = vbSunday
    Offs = 1
    hr = 24
    hr1 = 24 - ((Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60))
ElseIf Priorite = "p2" Then
    FirstDay = vbSaturday
    Offs = 2
    hr = 9
    If DateDiff("d", dte1, dte2) = 0 Then
        hr1 = 9 - ((Hour(dte2) + Minute(dte2) / 60) - (Hour(dte1) + Minute(dte1) / 60))
    Else
        If Not ferie(dte1) Then hr1 = (Hour(dte1) + Minute(dte1) / 60) - 9
        If Not ferie(dte2) Then hr2 = 18 - (Hour(dte2) + Minute(dte2) / 60)
    End If
End If
 
For i = 0 To DateDiff("d", dte1, dte2)
    If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), FirstDay) > Offs Then nbjr = nbjr + 1
Next i
Res = nbjr * hr - hr1 - hr2
If Int(Res) = 0 Then
    NbHeures = Format(Int(Res * 60), "00") & "min"
Else
    NbHeures = Format(Int(Res), "00") & "h:" & Format(Int((Res - Int(Res)) * 60), "00") & "min"
End If
End Function

**imaril** · 29/01/2010, 14h01

Merci
Je passe le sujet en résolu des que j'ai fais tout les test

**mercatog** · 30/01/2010, 14h40

Bonjour

pour gérer si date1 et date2 sont fériés, à tester

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Public Function NbHeures(ByVal Priorite As String, ByVal dte1 As Date, ByVal dte2 As Date) As String
Dim nbjr As Integer
Dim i As Integer
Dim FirstDay As Byte, Offs As Byte, hr As Byte
Dim hr1 As Double, hr2 As Double
Dim Res As Double
 
If Priorite = "p1" Then
    For i = 0 To DateDiff("d", dte1, dte2)
        If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), vbSaturday) > 2 Then
            If DateDiff("d", dte1, DateAdd("d", dte1, i)) = 0 Then
                hr1 = 24 - (Hour(dte1) + Minute(dte1) / 60)
            ElseIf DateDiff("d", dte1, DateAdd("d", dte1, i)) = 0 Then
                hr2 = (Hour(dte2) + Minute(dte2) / 60)
            Else
                nbjr = nbjr + 1
            End If
        End If
    Next i
    Res = 24 * nbjr + hr1 + hr2
ElseIf Priorite = "p2" Then
    For i = 0 To DateDiff("d", dte1, dte2)
        If Not ferie(DateAdd("d", dte1, i)) And Weekday(DateAdd("d", dte1, i), vbSaturday) > 2 Then
            If DateDiff("d", dte1, DateAdd("d", dte1, i)) = 0 Then
                If Hour(dte1) <= 18 Then hr1 = 18 - (Hour(dte1) + Minute(dte1) / 60)
            ElseIf DateDiff("d", dte2, DateAdd("d", dte1, i)) = 0 Then
               If Hour(dte2) >= 9 Then hr2 = (Hour(dte2) + Minute(dte2) / 60) - 9
            Else
                nbjr = nbjr + 1
            End If
        End If
    Next i
    Res = 9 * nbjr + hr1 + hr2
End If
 
If Int(Res) = 0 Then
    NbHeures = Format(Int(Res * 60), "00") & "min"
Else
    NbHeures = Format(Int(Res), "00") & "h:" & Format(Int((Res - Int(Res)) * 60), "00") & "min"
End If
End Function

Difference entre 2 date (avec heure) en jours ouvrés [XL-2003]

Macros et VBA Excel

Discussions similaires

Partager

Partager