VBA ajouter n jours ouvrés à la date du jour

[C@thy]

Bonjour le forum,

je cherche à mettre dans une cellule la date du jour + 5 jours ouvrés

Function fer(an%) 'liste de tous les jours fériés
Dim pq
  pq = paq(an)
  fer = Array(DateSerial(an, 1, 1), DateSerial(an, 5, 1), DateSerial(an, 5, 8), DateSerial(an, 7, 14), DateSerial(an, 8, 15), DateSerial(an, 11, 1), DateSerial(an, 11, 11), DateSerial(an, 12, 25), pq + 1, pq + 39, pq + 50)
End Function


Function paq(a%, Optional T As Boolean = False) 'Calcul date de Pâques
Dim g&, c&, d&, h&, I&, r&
  paq = ""
  If a > 1582 Then
    g = a Mod 19
    c = Int(a / 100)
    d = Int(c / 4)
    h = (19 * g + c - d - Int((8 * c + 13) / 25) + 15) Mod 30
    I = (Int(h / 28) * Int(29 / (h + 1)) * Int((21 - g) / 11) - 1) * Int(h / 28) + h
    r = DateSerial(a - 400 * (a < 1900), 3, 28) + I - (2 + a + Int(a / 4) + I + d - c) Mod 7
    If T Then
      paq = IIf(Day(r) = 1, "1er", Day(r)) & " " & IIf(r > 3, "avril", "mars") & " " & a
    Else
      paq = Day(r) & "/" & Month(r) & "/" & a
      If a > 1899 Then paq = CDbl(CDate(paq))
    End If
  End If
End Function

Et c'est là que ça se corse :

dans une cellule je dois ajouter 5 jours ouvrés et dans une autre ... six semaines ouvrées!

Sub AjouterJoursOuves()
Dim an As Integer, I As Integer
Dim N, fr

an = Year(Date)
fr = fer(an)

N = Date + 1
For I = 0 To UBound(fr)
     If N = fr(I) Then
...
...
end sub

Si vous pouviez m'apporter votre aide je vous serai infiniment reconnaissante
Merci à vous

Bises

C@thy

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

Désolée Hasco, je ne me suis pas bien expliquée :
Ce que je souhaite faire :
une date de départ (c'est un jour de travail, donc toujours ouvré), par exemple aujourd'hui
en colonne G la date + 5j ouvrés
en colonne R la date + 6 semaines ouvrées,
le jour (lundi mardi... on s'en fiche, j'ai mis en rouge le jeudi parce qu'aujourd'hui c'est jeudi, mais demain je mettrai en rouge le vendredi c'est juste pour m'y repérer dans mon calcul...

edit : par exemple si la date de départ est vendredi 28 octobre je dois obtenir lundi 7 novembre soit 5 jours ouvrés plus tard, ce qui fait en tout 8 jours plus tard et non 7 à cause jour férié du 1/11

Merci à toi, je teste ta nouvelle version et je te dis

Bises

C@thy

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

je m'explique :
je prends une date de départ qui est un jour ouvré,

je rajoute 5 jours sans compter samedi + dimanche + férié

ex. date départ = jeudi 27 octobre 2011
je rajoute 1 jour je teste
si c'est pas férié je compte ce jour sinon je ne le compte pas
j'obtiens vendredi 28 octobre 2011 qui compte car ouvré donc mon compteur est à 1
je rajoute 1 jour je teste
si c'est pas férié je compte ce jour sinon je ne le compte pas
j'obtiens le samedi 29 que je ne compte pas car samedi = non ouvré mon compteur est toujours à 1
je rajoute 1 jour je teste
si c'est pas férié je compte ce jour sinon je ne le compte pas
j'obtiens le dimanche 30 novembre que je ne compte pas car dimanche = non ouvré mon compteur est toujours à 1
je rajoute 1 jour je teste
si c'est pas férié je compte ce jour sinon je ne le compte pas
j'obtiens le lundi 31 octobre qui compte car ouvré
c'est donc mon 2ème jour compté (= ouvré) mon compteur est à 2
je rajoute 1 jour je teste
si c'est pas férié je compte ce jour sinon je ne le compte pas
j'obtiens mardi 1er novembre qui ne compte pas car férié mon compteur est toujours à 2
je rajoute 1 jour je teste
si c'est pas férié je compte ce jour sinon je ne le compte pas
j'obtiens le mercredi 2 novembre qui compte
ce jour compte car ouvré mon compteur est à 3
je rajoute 1 jour je teste
si c'est pas férié je compte ce jour sinon je ne le compte pas
j'obtiens le jeudi 3 novembre qui compte car ouvré mon compteur est à 4
je rajoute 1 jour je teste
si c'est pas férié je compte ce jour sinon je ne le compte pas
j'obtiens le vendredi 4 novembre, qui compte car ouvré mon compteur est à 5
j'ai ma date + 5 jours ouvrés j'écris cette date dans la colonne G

ensuite je passe à autre chose (les 6 semaines ouvrées)...

j'espère que c'est plus clair pour toi.

Je te remercie de tous tes efforts pour me rendre service

Bizz


C@thy

 

[Guest]

Re : VBA ajouter n jours ouvrés à la date du jour

Re,

Euh ben j'avais compris avec ton post précédent. Suis encore pas totalement demeuré même si ça ne saurait tardé

Ci-dessous:
Ecriture d'une fonction AjouteJourOuvré, d'une boucle de base pour ajouter 1 tant qu'une date est un jour est férié, samedi ou dimanche
La même boucle sous forme de fonction.

En ce qui concerne le 14/10 en lieu et place du "10/11", comme il s'agit d'une exception, je le rajouterai (14/11/2011") au tableau fériés.

Petite question pourquoi ne pas utiliser l'utilitaire d'analyse et sa fonction SERIE.JOUR.OUVRE ?

Sub AjouterJoursOuvrés()
    Dim an As Integer, i As Integer, a As Integer
    Dim N As Long, fr
    a = 1    'j'ai rajouté
    an = Year(Date)
    fr = fer(an)
   
    N = AJouteJoursOuvrés(Date, 5, fr)
    Range("G" & a) = CDate(N)    'j'ai modifié A1
    
    N = DateAdd("ww", 6, Date)
    Do While Not IsError(Application.Match(CLng(N), Fériés, 0)) Or Weekday(N) = 1 Or Weekday(N) = 7
        N = N + 1
    Loop
    Range("R" & a) = CDate(N)
End Sub
 
Function AJouteJoursOuvrés(ByVal d As Long, nbJours As Integer, Fériés As Variant) As Long
    Dim i As Integer, bAjoute As Boolean
    For i = 1 To nbJours
        d = d + 1
        Do While Not IsError(Application.Match(CLng(d), Fériés, 0)) Or Weekday(d) = 1 Or Weekday(d) = 7
            d = d + 1
        Loop
    Next
    AJouteJoursOuvrés = d
End Function
 
 
Function GetDateOuvrée(ByVal d As Long, nbJours As Integer, Fériés As Variant) As Long
    'Regarde si la date d est une date fériée ou un samedi ou dimanche et lui ajoute 1 tant que vrai
    'pour tomber sur le jour ouvré le plus proche après
    Do While Not IsError(Application.Match(CLng(d), Fériés, 0)) Or Weekday(d) = 1 Or Weekday(d) = 7
        d = d + 1
    Loop
    GetDateOuvrée = d
End Function

A+

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

Euh ben j'avais compris avec ton post précédent. Suis encore pas totalement demeuré même si ça ne saurait tardé

hihi! Non, t'es pas demeuré... euh... bien moins que moi en tout cas! Loool

le fait de mettre tout ça par écrit m'a aidée aussi à voir comment cela pouvait fonctionner

En ce qui concerne le 14/10 en lieu et place du "10/11", comme il s'agit d'une exception, je le rajouterai (14/11/2011") au tableau fériés.

Euh... ... loool... ça t'étonne???

Petite question pourquoi ne pas utiliser l'utilitaire d'analyse et sa fonction SERIE.JOUR.OUVRE ?

réponse : parce que ce n'est pas coché chez les utilisateurs du coup ça se complique, il faut l'activer par macro, j'ai essayé mais pas réussi.

Je teste ta nouvelle macro.

Merci pour ta ténacité

Zoubis

C@thy

 

[Guest]

Re : VBA ajouter n jours ouvrés à la date du jour

Re,

Les dates c'est chiant

En ce qui concerne le 14/10 en lieu et place du "10/11", comme il s'agit d'une exception, je le rajouterai (14/11/2011") au tableau fériés.

Je parle du cas des 6 semaines jour ouvrés à partir d'aujourdhui. Que ce soit les fonctions écrites plus haut ou la fonction SERIE.JOUR.OUVRE le résultat est 10/11/2011. Résultat normal puisque c'est un jour Ouvré et qu'il tombe 6 semaine après aujourd'hui.

comme tu veux pour résultat le 14/11/2011, (on est dans l'exceptionnel) et que toutes les dates fériés sont des dates 'exceptionnelles' et qu'elles sont contenues dans un tableau 'fr' on peut rajouter dans ce tableau toutes les dates que tu veux exclure du comptage des jours ouvrés (les ponts, les fin week-end qui n'en finissent pas, les dates où tu as prévu un 'blocage réveil' etc. etc.)

Est-ce mieux ainsi?

A+

A+

 

[Guest]

Re : VBA ajouter n jours ouvrés à la date du jour

Re,

C@thy, dans mon avant dernier post j'ai oublié une correction (copier/coller malheureux)

il faut mettre fr (ton tableau de fériés) dans la boucle, comme ci-dessous dans la sub:AjouterJoursOuvrés()


Do While Not IsError(Application.Match(CLng(N), Fr, 0)) Or Weekday(N) = 1 Or Weekday(N) = 7
N = N + 1
Loop

A+

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

Coucou,

sachant que 6 semaines c'est 6 fois 5 jours ouvrés donc 30 jours, sur le même principe que les 5 jours, ceci marche à merveille :

Sub AjouterJoursOuvrés()
      Dim an As Integer, i As Integer, a As Integer
      Dim N As Long, fr
      a = 1
     an = Year(Date)
      fr = fer(an)
     
      N = AJouteJoursOuvrés(Date, 5, fr) '5 jours
      Range("G" & a) = CDate(N)
       N = AJouteJoursOuvrés(Date, 30, fr) '6 semaines
      Range("R" & a) = CDate(N)
  End Sub

Bises

C@thy

 

[Guest]

Re : VBA ajouter n jours ouvrés à la date du jour

Re,

Chez moi cela tombe le 15/11 et non le 14!?

Mais tant mieux si cela te va.

[Edit] erreur , j'avais déjà rajouté le 10/11 dans le tableau des fériés(chez moi) donc +1 dans le comptage.

Alors c'est tout bon.
A++

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

Les dates c'est chiant

Je l'ai toujours dit, la vie serait tellement mieux s'il n'y avait que des jours fériés!!!

Mille mercis pour ton aide, ta fonction AJouteJoursOuvrés est SUPER, elle va me reservir!

Bisous et bonne journée

C@thy

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

Coucou Hasco,
peux-tu me dire à quoi sert ceci :

Do While Not IsError(Application.Match(CLng(d), Fériés, 0))

j'ai dû réécrire mon application sous Outlook, et du coup j'ai été obligée de retirer cette instruction qui ne passait plus (Application faisait référence à Excel)

voici l'intégralité de mon appli (dans un module Outlook) :

Sub TraiterCourriersInBox()
'Définition des variables application
Dim OLmail As MailItem
Dim objOLApp As Outlook.Application     'Pour définir l'Application Outlook
Dim objNS As NameSpace                  'Espace Outlook
Dim objInbox As Outlook.MAPIFolder      'Boîte de courriers Arrivée
Dim objDestFolder As Outlook.MAPIFolder 'Boîte d'archivage des courriers traités dans Excel
'Application Excel
Dim objXlApp As New Excel.Application   'Pour définir l'Application Excel
Dim objXlClas As Excel.Workbook         'Pour définir le Classeur Excel
'Définition des variables de travail
    Dim an As Integer, I As Integer
    Dim N As Long, a As Long, nbJours As Long, fr, v
    Dim balOutlook As String
    Dim an_arr As Integer
    Dim incremen_arr As Variant
    
'Instanciation des variables application
Set objOLApp = Outlook.Application
Set objNS = objOLApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox) 'Boîte de réception
    v = Split(objInbox.FolderPath, "\")
    balOutlook = v(UBound(v) - 1) 'découpage chemin Boîte de réception
Set objInbox = objNS.Folders(balOutlook).Folders("Prise en charge demande")
Set objDestFolder = objInbox.Folders("suivi demandes")
Set objXlClas = objXlApp.Workbooks.Open("W:\TestOutlook.xls")

'initialisation des variables de travail
     an = Year(Date)
     fr = Fer(an) 'calcul des jours fériés de an
     N = CLng(Date) + 1

'Traitement courriers
For Each OLmail In objInbox.Items
    With objXlClas.Worksheets(1) '1ère Feuille du classaur
           a = .Range("A65536").End(-4162).row + 1
            'déconposition de l'id arrivé
           an_arr = Left(.Range("A" & a - 1).Value, 4)
           an = Year(Date)
           If an_arr < an Then
              an_arr = Year(Date)
              incremen_arr = "00"
           Else
              incremen_arr = Right(.Range("A" & a - 1), 3)
           End If
   incremen_arr = incremen_arr + 1
   Do Until Len(incremen_arr) = 3
      incremen_arr = "0" & incremen_arr
   Loop
'incrémente la partie droite du num id
   num_id_arrivé = an_arr & "-" & incremen_arr
           .Range("A" & a).Value = num_id_arrivé
           .Range("B" & a).Value = OLmail.CreationTime
           .Range("C" & a).Value = Date
           .Range("D" & a).Value = OLmail.SenderName
           .Range("F" & a).Value = OLmail.Subject
           N = AJouteJoursOuvrés(Date, 5, fr)
           .Range("G" & a).Value = CDate(N)
           N = AJouteJoursOuvrés(Date, 30, fr)
           .Range("R" & a).Value = CDate(N)
           OLmail.Move objDestFolder 'archivage
    End With
Next OLmail
    'On sauvegarde et ferme le fichier Excel
    objXlClas.Save
     objXlClas.Close 'True
    'On quitte Excel
     objXlApp.Quit
    'On libère les ressources
     Set objXlClas = Nothing
     Set objXlApp = Nothing
End Sub
 Function AJouteJoursOuvrés(ByVal d As Long, nbJours As Integer, Fer As Variant) As Long 'calcul ajout de jours ouvrés
    Dim I As Integer, bAjoute As Boolean
    For I = 1 To nbJours
        d = d + 1
        Do While Weekday(d) = 1 Or Weekday(d) = 7 'Not IsError(Application.Match(CLng(d), Fer, 0)) Or
            d = d + 1
        Loop
    Next
    AJouteJoursOuvrés = d
End Function
Function Paq(ByVal an As Integer) As Date
Paq = DateSerial(an, 3, 23) + ((2 * (an Mod 4) + (4 * (an Mod 7) + _
   (6 * (((19 * (an Mod 19)) + 24) Mod 30) + 5))) Mod 7) + _
   ((19 * (an Mod 19) + 24) Mod 30) - 1
End Function
Function Fer(an%) 'liste de tous les jours fériés
Dim pq
pq = Paq(an)
Fer = Array(CLng(DateSerial(an, 1, 1)), CLng(DateSerial(an, 5, 1)), CLng(DateSerial(an, 5, 8)), CLng(DateSerial(an, 7, 14)), CLng(DateSerial(an, 8, 15)), CLng(DateSerial(an, 11, 1)), CLng(DateSerial(an, 11, 11)), CLng(DateSerial(an, 12, 25)), pq + 1, pq + 39, pq + 50)
End Function

Bises

C@thy

 

[Guest]

Re : VBA ajouter n jours ouvrés à la date du jour

Bonjour C@thy,

Application.MAtch est l'équivalent de la fonction de feuille de calcul EQUIV.

Dans la fonction ci-dessous(non-testée) le tableau des fériés est transformé en chaine de caratère contenant tous les numéros de férié séparé par un ";" strFériés= Join(....)

Ensuite la fonction Instr dira s'il y a ou non présence dans cette chaine de la chaine correspondant au jour testé cstr(d) & ";" elle renvoie un numéro de position qui doit être 0 pour ne pas corrrespondre à un férié. Cette méthode évite de refaire une boucle sur le tableau des fériés.

Function AJouteJoursOuvrés(ByVal d As Long, nbJours As Integer, Fer As Variant) As Long 'calcul ajout de jours ouvrés
    Dim I As Integer, bAjoute As Boolean
 
    'StrFériés contiendra une chaine de tous les jours fériés séparés par un point virgule
    Dim strFériés As String: strFériés = Join(Fer, ";")
 
    For I = 1 To nbJours
        d = d + 1
        'Si d est un dimanche ou Samedi ou s'il est trouvé dans strFériés alors ajourter un jour
        Do While Weekday(d) = 1 Or Weekday(d) = 7 Or InStr(1, strférié, CStr(d) & ";") > 0
            d = d + 1
        Loop
    Next
    AJouteJoursOuvrés = d
End Function

A+

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

OK, en faisant une recherche sur le forum j'ai trouvé
ce lien

mais... j'ai toujours pas tout compris (ça va venir!!)
ça sert à trouver si la date est dans la table des fériés... donc si je l'enlève c'est pas bon???

je teste ta 2ème version

Bises

C@thy

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

OK, j'ai testé, il me manque 2 jours dans les 6 semaines ouvrées il ne décale pas d'1j pour le 1/11 et 1 autre pour le 11/11

StrFériés =

"40544;40664;40671;40738;40770;40848;40858;40902;25/04/2011;02/06/2011;13/06/2011"

je change de type (nombre ou date) au milieu de StrFériés c'est à cause de ma fonction Paq

C@thy

 

[C@thy]

Re : VBA ajouter n jours ouvrés à la date du jour

j'ai fait une série jours ouvrés en descendant la curseur depuis A1 avec le clic droit de la souris comme ça ça enlève directement les samedis et dimanches

 

[Guest]

Re : VBA ajouter n jours ouvrés à la date du jour

Re,
Réponse à ton post #28

Dans un post précédent je te disais, qu'il est important quand on travaille avec des dates de les transformer en Type Long (ou double) pour éviter ce genre les conversion implicites intenpestives et qui font que dans ton tableau de fériés tu te retrouve avec des dates en type long et d'autres en type date:

StrFériés = "40544;40664;40671;40738;40770;40848;40858;40902;2 5/04/2011;02/06/2011;13/06/2011"

Dans la fonction AJouteJoursOuvrés on passe la date en long il faut donc que la chaine de caratères ne contienne que la concaténation de nombre de Type long. Ou alors tu passes tout ton tableau de Fériés en type Date (plus dangereux, moins souple).

Ton tableau de fériés en types long:

Function Fer(an%) 'liste de tous les jours fériés
Dim pq As Long
pq = CLng(Paq(an))
Fer = Array(CLng(DateSerial(an, 1, 1)), CLng(DateSerial(an, 5, 1)), CLng(DateSerial(an, 5, 8)), CLng(DateSerial(an, 7, 14)), CLng(DateSerial(an, 8, 15)), CLng(DateSerial(an, 11, 1)), CLng(DateSerial(an, 11, 11)), CLng(DateSerial(an, 12, 25)), pq + 1, pq + 39, pq + 50)
End Function

C'est pour cette raison(mélange longs et dates) que Instr ne trouvait pas la date du 1/11 et autre.

Pour passer de type date en long tu peux soit utiliser Clng() soit multiplier une date par 1

exemple: DateSerial(an, 11, 11)*1 qui donnera 40848 pour cette année.

Je regarde ton post#29 et y répond sous peu.

A+