Connaitre les jours ouvrés ( sans les samedi , dimanche et jours fériés ) entre 2 dates données .

Mais parcequ'il y a un mais avec une option de tri pour chaque mois ( automatique tant qu'a faire!!!! )
c'est à dire exemple : du 01/01/01 au 15/04/01 j'aurrais pour : Janvier 22 jours ouvrés, Février 20 jours ouvrés, Mars 22 jours ouvrés, Avril 10 jours ouvrés
La procédure que je propose est à recopier dans un module standard du classeur et à relier à un bouton.
Elle utilise la fonction TYPEJOUR de Laurent Longre pour déterminer les jours ouvrés entre les deux dates qui sont demandées en début de code (inputbox) indiqué la cellule de date
Les jours ouvrés sont stockées dans un tableau. Puis triés par mois.
Le résultat du tri est récupéré dans une chaine, le résultat de chaque mois étant séparé du suivant par une virgule.
Laquelle sert de séparateur à la fonction Split pour transformer la chaine en un nouveau tableau, et ce tableau est enfin renvoyé vers une plage de la feuille (qui débute ici en C1, à adapter).
La fonction Split étant apparue dans Excel 2000, si tu travailles avec Excel 97, je te mets en fin de code une fonction de substitution.
Pour l'utiliser il faut décommenter la ligne ' tabResult = Split_97(Left(S, Len(S) - 1), ",") 'Excel 97 et mettre en commentaire la ligne juste au-dessus.
Sub NbOuvresParMois()
Dim tabOuvres As Variant, i As Date, D1 As Date, D2 As Date
Dim MoisDeb, MoisFin, x%, S$, tabResult, Titre$
Titre = "Sélectionnez une cellule"
D1 = Application.InputBox("Date de départ :", Titre, , , , , , 8)
D2 = Application.InputBox("Date de fin :", Titre, , , , , , 8)
ReDim tabOuvres(0)
For i = D1 To D2
If TYPEJOUR(i) = 0 Then
tabOuvres(UBound(tabOuvres)) = i
ReDim Preserve tabOuvres(UBound(tabOuvres) + 1)
End If
Next i
MoisDeb = Month(D1): MoisFin = Month(D2)
For x = MoisDeb To MoisFin
nb = 0
Mois = Application.WorksheetFunction. _
Proper(Format(DateSerial(1900, x, 1), "mmmm"))
For Each jour In tabOuvres
If Month(jour) = x Then nb = nb + 1
If Month(jour) = x + 1 Then Exit For
Next jour
S = S & Mois & " : " & nb & " jours ouvrés,"
Next x
tabResult = Split(Left(S, Len(S) - 1), ",") 'Excel 2000
' tabResult = Split_97(Left(S, Len(S) - 1), ",") 'Excel 97
Range("C1:C" & UBound(tabResult) + 1) = _
Application.WorksheetFunction.Transpose(tabResult)
End Sub
'Cette fonction renvoie 0 si le jour passé en paramètre est un jour de semaine,
'1 s'il s'agit d'un samedi ou d'un dimanche et 2 s'il s'agit d'un jour férié.
'Valide jusqu'en 2099 et pour les jours fériés français
Function TYPEJOUR(D As Date)
'L. Longre
Dim A As Integer, T As Integer
Dim LP As Date, LD As Long
Dim Toto As Long
A = Year(D)
If A > 2099 Then
TYPEJOUR = CVErr(xlErrValue)
Exit Function
End If
LD = Int(D)
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
Function Split_97(Chaine$, Separateur$)
'FS
Dim Tablo(), pos%, S$
S = Trim(Chaine): ReDim Tablo(0)
Recurse:
pos = InStr(1, S, Separateur)
If pos = 0 Then
Tablo(UBound(Tablo)) = S
Split_97 = Tablo()
Exit Function
Else
Tablo(UBound(Tablo)) = Left(S, pos - 1)
S = Right(S, Len(S) - pos)
ReDim Preserve Tablo(UBound(Tablo) + 1)
GoTo Recurse
End If
End Function
}

 

  Retour liens Excel