bonsoir Monique , Dugenou et Tracor
j'espere que cette macro pourra t'aider . La fonction de calcul des jours feries et weekends est de Laurent Longre
dans l'exemple , les dates d'expedition doivent etre dans la colonne A , et les date de livraison dans la colonne B
un delai est considéré comme dépassé si la durée est superieure à deux jours( le jour de l'expedition n'est pas comptabilisé dans le calcul de durée )
Sub DelaisJoursOuvres()
'dans cet exemple les samedi ne sont pas comptés en jour ouvré
Dim Debut As Date, Fin As Date
Dim Compte As Byte, Total As Byte, i As Byte
Dim Cell As Range
Dim Tableau() As Byte
Dim Repartition As String
Dim NbExp As Integer
'colonne A date d'expedition
'colonne B date de livraison
NbExp = Range("A65536").End(xlUp).Row
ReDim Tableau(0)
For Each Cell In Range("A1:A" & NbExp)
Compte = 0
Debut = CDate(Cell) 'date expedition
Fin = CDate(Cell.Offset(0, 1)) 'date livraison
While Debut < Fin
Debut = Debut + 1
If Not TYPEJOUR(Debut) = 2 And Not TYPEJOUR(Debut) = 1 Then Compte = Compte + 1
'pour comptabiliser les Samedi comme jours ouvrés
'If Not TYPEJOUR(Debut) = 2 And Weekday(Debut, vbMonday) <>7 Then Compte = Compte + 1
Wend
If Compte > 2 Then
If UBound(Tableau()) < Compte Then
ReDim Preserve Tableau(Compte)
Tableau(Compte) = Tableau(Compte) + 1
Else
Tableau(Compte) = Tableau(Compte) + 1
End If
Total = Total + 1
End If
Next
MsgBox "Nombre de livraisons dont le délai est supérieur à 2 jours : " & Total, , "Resultat"
For i = 3 To UBound(Tableau())
' ! le pourcentage est calculé sur le nombre total d'expeditions
Repartition = Repartition & i & " jours : " & vbTab & Tableau(i) & vbTab & " soit " & Format(Tableau(i) / NbExp, "0.00%") & Chr(10)
Next i
MsgBox Repartition, , "Repartition des dépassements "
End Sub
Function TYPEJOUR(D As Date)
'procedure de Laurent Longre
Dim A As Integer, T As Integer
Dim LP As Date, LD As Long
A = Year(D)
If A > 2099 Then
TYPEJOUR = CVErr(xlErrValue)
Exit Function
End If
LD = Int(D) + 1
If LD <= 2 Then
If LD = 1 Then TYPEJOUR = 2
Exit Function
End If
T = (((255 - 11 * (A Mod 19)) - 21) Mod 30) + 21
LP = DateSerial(A, 3, 2) + T + (T > 48) + 6 - ((A + A \ 4 + T + (T > 48) + 1) Mod 7)
Select Case D
' Jours fériés mobiles
Case Is = LP, Is = LP + 38, Is = LP + 49
TYPEJOUR = 2
' Jours fériés fixes
Case Is = DateSerial(A, 1, 1), Is = DateSerial(A, 5, 1), _
Is = DateSerial(A, 5, 8), Is = DateSerial(A, 7, 14), _
Is = DateSerial(A, 8, 15), Is = DateSerial(A, 11, 1), _
Is = DateSerial(A, 11, 11), Is = DateSerial(A, 12, 25)
TYPEJOUR = 2
Case Else
' Samedi ou dimanche
If Weekday(D, vbMonday) >= 6 Then TYPEJOUR = 1
End Select
End Function
bonne soiree
MichelXld
