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

 

[Guest]

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

Bonjour Cathy

Dans l'exemple suivant tu trouveras une fonction qui te donne le jour ouvré suivant (ou précédent)une date. Le paramètre Incr permet d'incrémenter(1,2,..) ou décrémenter(-1,-2..) la date de Incr jour(s).

Dans le travail en vba et les dates il vaut mieux utiliser les Long plutôt que directement les types date. J'ai changé à cet effet un peu la fonction fer dont le tableau final comportait des types date et type long mélangés.

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
 
 
Function GetDateOuvrée(ByVal d As Long, Fériés As Variant, Optional incr As Integer = 1) As Long
Do While Not IsError(Application.Match(CLng(d), Fériés, 0)) Or Weekday(d) = 1 Or Weekday(d) = 7
d = d + incr
Loop
GetDateOuvrée = d
End Function

Mais la fonction EXCEL SERIE.JOUR.OUVRE fonctionne très bien en vba:
Debug.Print Format(Application.WorkDay(CDate("23/04/2011"), 1, fr), "dd/mm/yyyy")

où fr est le tableau des jours fériés

A+

 

[C@thy]

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

Je te remercie Hasco, je n'ai pas encore réussi à l'appliquer à mon problème...

mettre dans une cellule la date du jour + 5 jours ouvrés
et dans une aute la date du jour + 6 semaines ouvrées...

Edit : je ne comprends pas d'où vient fériés par rapport à Fer...

C@thy

 

[Guest]

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

Re bonjour C@thy,

Sur la base que tu as donnée en post #1:
(Fériés de la fonction 'GetDateOuvrée' est le tableau de tes fériés calculés en amont, fr et que tu lui passe en paramètre)

Sub AjouterJoursOuvrés()
Dim an As Integer, I As Integer
Dim N, fr
an = Year(Date)
fr = fer(an)
N = Date
For I = 1 To 5
N = GetDateOuvrée(N + I, fr)
Cells(I, 1) = N
Next
Cells(I + 1, 1) = GetDateOuvrée(DateAdd("ww", 6, Date), fr)
End Sub

La dernière ligne ajoute 6 semaines à la date du jour et trouve un jour ouvré dans la semaine trouvée.

A+

 

[C@thy]

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

Merci Hasco,

si je dis aujourd'hui(mardi)
date + 5 = mardi prochain (y'a pas de jours fériés en septembre-octobre) donc le mardi 4/10/2011
or j'obtiens mercredi 12 octobre...

Bises

C@thy

 

[Guest]

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

Re,

Oui, c'est parceque j'ajouté I à N et non 1:

Sub AjouterJoursOuvrés()
    Dim an As Integer, I As Integer
    Dim N As Long, fr
    an = Year(Date)
    fr = fer(an)
    N = CLng(Date) + 1
    For I = 1 To 5
        N = GetDateOuvrée(N, fr)
        Cells(I, 1) = N
        N = N + 1
    Next
    Cells(I + 1, 1) = GetDateOuvrée(DateAdd("ww", 6, Date), fr)
End Sub

Avec la fonction EXCEL SERIE.JOUR.OUVRE (WORKDAY)

Sub AjouterJoursOuvrés()
    Dim an As Integer, I As Integer
    Dim N As Long, fr
    an = Year(Date)
    fr = fer(an)
    N = CLng(Date)
    For I = 1 To 5
       Cells(I, 1) = Application.WorkDay(N, I, fr)
    Next
    
    N = CLng(DateAdd("ww", 6, Date))
    Cells(I + 1, 1) = Application.WorkDay(N, 1, fr)
End Sub

A+

 

[C@thy]

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

Ok ça roule merci bôcoup

Bisous

Merci

C@thy

 

[C@thy]

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

Merci Hasco, c'est parfait!
J'ai juste fait For I = 1 To 4
car on ajoute déjà 1 à la date au début, donc il ne reste plus que 4 à ajouter.

Oili Oilà!

Mille mercis

Bizz

C@thy

Edit : j'ai aussi mis l'écriture dans la cellule après la boucle for car je n'ai besoin que de la date du jour + 5 (dans une seule cellule) pas des 5 dates.

la version avec

Cells(I, 1) = Application.WorkDay(N, I, fr)

me dit propriété ou méthode non gérée par cet objet, mais c'est pas grave, la 1ère fonctionne très bien.

Par contre je viens de m'apercevoir que la date + 6 semaines me donne 6 jeudis plus tard alors qu'il y a le 1er novembre, je devrais donc avoir un vendredi,

je regarde ça et je te dis.

Bisous

C@thy

Edit j'ai remis le +5 c'était bon

 

[C@thy]

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

Bon, j'ai trouvé d'où vient le blème :

je ne veux l'écrire qu'une fois, donc j'ai enlevé l'écriture de la boucle :

For I = 1 To 5
        N = GetDateOuvrée(N, fr)
        N = N + 1
    Next
     Cells(I, 1) = N

le problème c'est qu'on a fait +1 et que donc I est égal à 6 quand on sort de la boucle...

je vais faire :

Cells(I, 1) = N-1

, normalement, ça doit être bon...
pour les 6 semaines, je crois que je vais ajouter 35 à la date aujourd'hui + 5 jours ouvrés que je viens de calculer, qu'en penses-tu?

Merciiiiiiiiiii

Bises

C@thy

 

[Guest]

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

Bonjour C@thy,

Amélioration pour ton cas. Que tu n'avais pas précisé dans ta demande initiale.

La fonction GetDateOuvrée (écrite comme ci-dessous) ajoutera nbJours à la date de départ et l'incrémentera de 'Incr' jours jusqu'à trouver un jour qui ne soit ni Samedi ni dimanche ni férié.

Sub AjouterJoursOuvrés()
Dim an As Integer, I As Integer
Dim N As Long, fr
an = Year(Date)
fr = fer(an)
N = GetDateOuvrée(Date, 5, fr)
Range("A1") =CDate(N)
End Sub
 
Function GetDateOuvrée(ByVal d As Long, nbJours As Integer, Fériés As Variant, Optional incr As Integer = 1) As Long
d = d + nbJours
Do While Not IsError(Application.Match(CLng(d), Fériés, 0)) Or Weekday(d) = 1 Or Weekday(d) = 7
d = d + incr
Loop
GetDateOuvrée = d
End Function

Pour trouver un jour ouvré 6 semaines à partir d'aujourd'hui, si avec DateAdd cela ne convient pas:
N=GetDateOuvrée(Date, 6*7,fr)
devrait le faire.

A+

 

[C@thy]

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

Merci Hasco!

C'est vrai, je n'avais pas été claire...

tu tombes bien car j'étais en plein dans le cambouis, vé tester tout de suite ce que tu me dis

Bises et merci

C@thy

 

[C@thy]

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

je commence à comprendre (un peu) comment ça fonctionne...
Résultat du test :
fichier joint (faut cliquer sur le bouton pour exécuter)

Je te remercie vivement pour ton aide

Bises

C@thy

 

[Guest]

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

C@thy,

Tu dis dans ton fichier vouloir obtenir Jeudi 6 octobre, en rajoutant 5 jours ouvrés à la date d'aujourd'hui (29/09/2011). Ce que je vois, c'est que tu as mis en rouge "tous" les jeudi. Apparament ce que tu veux c'est trouver le jour de semaine (Lun.....Vend) suivant qui soit ouvré?

Est-cela?

si oui, il suffit de mettre :

N = GetDateOuvrée(Date, 7, fr)

Mais il y a d'autres fonctions pour ça.

Précise ton besoin le plus clairement possible.

A+

 

[C@thy]

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

Re,

j'ai bidouillé un truc qui fonctionne,
mais je ne sais pas si c'est bon dans tous les cas.

Pour la date du 29/9 comme départ, ça marche, mais j'en conviens c'est de la bidouille...

For I = 1 To 5
                    N = GetDateOuvrée(N, fr)
                    N = N + 1
                Next
                Range("G" & a) = CDate(N - 1)
                For I = 1 To 27
                    N = GetDateOuvrée(N, fr)
                    N = N + 1
                Next
                Range("R" & a) = CDate(N - 1)

Bises

Edit :
eh ben non, si j'essaie avec date -14 ça marche pas!!!

C@thy

 

[Guest]

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

C@thy,

Je ne sais pas quoi te dire, car je ne sais pas exactement ce que tu cherches:

1- Ajouter 5 jour à une date et renvoyer le jour ouvré le plus proche (après)
2- ou trouver le prochain jeudi (ou autre jour de semaine suivant la date de départ ) qui soit ouvré
3- trouver le prochain jeudi (idem) et retourner le jour ouvré le plus proche.

Ces trois demandes (et il peut y en avoir d'autres) sont différentes.

Maintenant en ce qui concerne ta demande pour la 6ème semaine suivante:
si ta date de départ et un jeudi et que le jeudi de la 6ème semaine suivante est un jour ouvrés, n'importe quelle fonction te retournera ce jour là "10/11/2011" et pas lundi "14/11/2011" à moins de lui demander explicitement, par exemple en l'incluant dans les fériés.

Voici une autre macro corrigée en fonction de ce qui me semble être ta demande:
La fontion NièmeProchaine retourne par exemple le 5 jeudi suivant une date. Je l'ai commentée afin que tu puisses faire tes essais et voir ce qui te convient.

Public Function NièmeProchain(ByVal Nième As Integer, ByVal DateRéférence As Date, Optional ByVal JourSem As Byte = 0, Optional bDateRefExclue As Boolean = True) As Long
'Trouve le Nième jour(Lundi=1,...Dimanche=7) semaine suivant une date de référence (exclue ou non par le paramètre bDateRefExclue)
'Param Nième: numéro d'ordre du jour à trouver (1, 2,3,etc. ème )
'Param DateRéférence: date de départ
'Param JourSem: si on veut un jour différent (ex Vendredi) au lieu du jour de la date référence,
' indiquer dans ce paramètre son numéro d'ordre dans la semaine '1=lundi 7=dimanche
 
'Exemple: Trouver le 5ème jeudi suivant la date du jour
' LaDate= NièmeProchain(5,date,4)
' La même chose sans compter la date de départ (peut donner le même résultat)
' NièmeProchain (5,date,4,false)
If JourSem < 1 Or JourSem > 7 Then JourSem = Weekday(DateRéférence) - 1
If bDateRefExclue Then
NièmeProchain = DateRéférence - Weekday(DateRéférence - JourSem) + 1 + 7 * Nième
Else
NièmeProchain = DateRéférence - Weekday(DateRéférence - JourSem - 1) + 7 * Nième
End If
End Function
Sub GetDateOuvrée2()
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 = NièmeProchain(1, Date)
 
'Vérifie si la date renvoyée est un jour ouvré ou non, éventuellement la corrige
Do While Not IsError(Application.Match(CLng(N), fr, 0)) Or Weekday(N) = 1 Or Weekday(N) = 7
N = N + 1
Loop
 
Range("G" & a) = CDate(N) 'j'ai modifié A1
N = NièmeProchain(6, Date)
 ' nièmeProchain(6,date,1,false) 'forcera à trouver le lundi suivant
'Vérifie si la date renvoyée est un jour ouvré ou non, éventuellement la corrige
Do While Not IsError(Application.Match(CLng(N), fr, 0)) Or Weekday(N) = 1 Or Weekday(N) = 7
N = N + 1
Loop
 
Range("R" & a) = CDate(N)
End Sub

A+