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

C@thy · 27 Septembre 2011

Bonjour le forum,

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

Code:

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!

Code:

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 · 22 Décembre 2011

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

Coucou me revoilou,

j'ai avancé sur le sujet mais... agrrrr... ça ne marche pas
il ne doit pas manquer grand chose, je pense...
Code :
Public D1 As Date, D2 As Date, an As Integer
Sub CalculJoursOuvres()
D1 = DateSerial(2011, 12, 22)
D2 = DateSerial(2011, 12, 26)
Toto = NBJoursOuvres(D1, D2)
MsgBox Toto
End Sub

Function NBJoursOuvres(D1, D2)
Dim I As Long
an = Year(Date)
For I = D1 To D2
NBJoursOuvres = NBJoursOuvres + (Weekday(CDate(I)) <> 1 And _
Weekday(CDate(I)) <> 7) And CDate(I) <> Fer(an) * True
Next
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)), CLng(pq) + 1, CLng(pq) + 39, CLng(pq) + 50)
End Function

j'ai une incompatibilité de type (encore un sale type!!!)

Je précise que les 2 dates sont dans la même année (année en cours).

Bises

C@thy

C@thy · 22 Décembre 2011

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

Avec l'aide de Pierre-Jean, mais ne donne pas le bon résultat

Sub test()
For A = 1 To 5
D1 = Range("B" & A).Value
D2 = Range("I" & A).Value
an = Year(Date)
For m = LBound(Fer(an)) To UBound(Fer(an))
lesferies = lesferies & CStr(Fer(an)(m)) & ","
Next m
For n = D1 To D2
If Weekday(n) <> 1 And Weekday(n) <> 7 And InStr(lesferies, CStr(CLng(n))) = 0 Then
nbJours = nbJours + 1
End If
Next n
Range("J" & A).Value = nbJours
Next A
End Sub

JCGL · 22 Décembre 2011

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

Bonjour à tous,
Re Cathy,

J'ai comparé ta fonction avecNB.JOURS.OUVRES() : les valeurs retournées sont identiques...
Déjà on peut supposer que c'est bon pour toi.

Reste l’incompatibilité...

Edition : Je n'ai pas incompatibilité...

Bises
A + à tous

C@thy · 23 Décembre 2011

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

Merci JC, mais pour moi le résultat n'est pas le bon car si tu fais simplement la différence en soustrayant
(signe -) mercredi 30 décembre de jeudi 31 décembre tu obtiens 1, ce qui pour moi est juste, car il y a 1 jour de différence entre les deux.
Là, j'ai toujours 1 jour de trop

OK, j'ai corrigé test comme ceci :

Code:

Sub test()
For A = 1 To 5
D1 = Range("B" & A).Value
D2 = Range("G" & A).Value
an = Year(Date)
  For m = LBound(Fer(an)) To UBound(Fer(an))
    lesferies = lesferies & CStr(Fer(an)(m)) & ","
  Next m
For n = D1 + 1 To D2
If Weekday(n) <> 1 And Weekday(n) <> 7 And InStr(lesferies, CStr(CLng(n))) = 0 Then
  nbJours = nbJours + 1
End If
Next n
Range("J" & A).Value = nbJours
nbJours = 0
Next A
End Sub

je ne sais pas si c'est la meilleure des solutions possibles...
(j'ai essayé lesferies = Join(Fer, ";") mais ça marche pô!)
...mais cela fonctionne (merci à Pierre-Jean de m'avoir mise sur la bonne voie)

Bises et bonne journée,

C@thy

C@thy · 13 Janvier 2012

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

Bonjour le forum,

je reprends ce fil fort intéressant... (du moins il me passionne)

voici ce que j'essaie de faire :

différence entre lundi 30/04/2012 et mercredi 02/05/2012 doit me donner 1 jour d'écart car le 1er mai est férié, j'ai donc répondu à la demande dans le délai d'1 jour et non pas 2
(je précise bien car si je fais le calcul entre 2 dates normales distantes d'un jour (par ex.le mardi et le mercredi non fériés de la même semaine) je dois obtenir 1 jour mais avec
=NB.JOURS.OUVRES(A1;B1;feries) j'obtiens le résultat 2
alors qu'avec B1-A1 j'obtiens le bon résultat à savoir 1)

euh... vous me suivez toujours...???

donc mon problème est le suivant : je veux calculer l'écart entre 2 dates :
A1 = lundi 30/04/2012 B1 = mercredi 02/05/2012 en C1 : = B1-A1 j'obtiens 1
A1 = mercredi 02/05/2012 B1 = lundi 30/04/2012 D2 en C1 : = B1-A1 j'obtiens -1

ça c'est une première énigme sur laquelle je me suis penchée...
(mais contrairement à la chanson d'Adamo, je n'ai pas entendu un requiem quand sur elle je me suis penchée...)

deuxième énigme (je penche de plus en plus... et je penche donc je suis...

) :

A1 = mercredi 02/05/2012 B1 = -1

opération à effectuer en C1 : = A1 + B1 = lundi 30/04/2012

Pire que ça :

A1 = lundi 02/01/2012 B1 = -1 résultat à obtenir en C1 : vendredi 30/12/2011

Arf! Si JNP me voit, il va encore me dire que je pose des questions 'achement dures

mais il me dirait sans doute aussi (enfin j'espère...) que ce sont les questions dures qui font progresser...

Merci à vous si vous avez une solution ou une partie de solution ou un début de piste

pour ne rien vous cacher j'ai fait des tentatives, mais j'ai un peu honte...

Code:

Function NBJoursOuvres(DateDebut, DateFin)
Dim I As Long  
an = Year(Date)
  For m = LBound(Fer(an)) To UBound(Fer(an))
    lesferies = lesferies & CStr(Fer(an)(m)) & ","
  Next m

If DateDebut < DateFin Then
    For I = DateDebut To DateFin
         NBJoursOuvres = NBJoursOuvres + (Weekday(CDate(I)) <> 1 And _
                           Weekday(CDate(I)) <> 7)  And InStr(lesferies, CStr(CLng(n))) = 0* True
        Next
    Else
    For I = DateDebut To DateFin Step -1
         NBJoursOuvres = NBJoursOuvres - (Weekday(CDate(I)) <> 1 And _
                           Weekday(CDate(I)) <> 7) And InStr(lesferies, CStr(CLng(n))) = 0 * True
    Next
    End If
End Function

Merci à vous et bonne journée

Bises

C@thy

Guest · 13 Janvier 2012

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

bonjour le fil et les filiens,

@C@thy nous avions déjà parlé des variables dates et long, je vois que cela n'a pas eu grande influence sur le résultat car dans ta fonction NbJoursOuvres il y a erreur de conversion et recherche:

lesferies ="40909,41030,41037,41104,41136,41214,41224,41268,09/04/2012,17/05/2012,28/05/2012"

clng(cdate(09/04/2012))= 41008 'ne sera jamais trouver dans ta chaine, plus loin dans la recherche des fériés : InStr(lesferies, CStr(CLng(n)))

Où n ne correspond à rien: non seulement il n'est pas déclaré, mais il n'est jamais initialisé à moins qu'il le soit ailleurs. Ce qui n'aurait pas de sens non plus.

De plus ta première boucle for fait appel 13 fois à fer(an%) qui elle-même fait appel 13 fois à paq(an) simplement pour retourner une chaine de 11 éléments?????

Tu te dirige tout droit vers l'usine à gaz

, à force de copier coller des morceaux que tu ne comprends visiblement pas

.

A+ les filiens et filiennes.

Bebere · 13 Janvier 2012

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

bonjour le fil
Cathy,cette fonction te serait peut être utile

Code:

'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

à bientôt

C@thy · 13 Janvier 2012

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

A Hasco :
oui, tu l'as remarqué, j'ai du mal, mais j'essaie...

A bebere : merci de ton aide

je vais tester ça.

Edit : Merci Bebere pour ta fonction, je la trouve sympa...
je ne sais pas trop si ça fait avancer mon schmilblick...

Bizzz

C@thy

Bebere · 13 Janvier 2012

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

Cathy
avec un code qui utilise typejour
à bientôt

C@thy · 13 Janvier 2012

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

Yes Bebere, on est sur la bonne voie,
un grand MERCI à toi.

Bises et bon ouik

C@thy

Guest · 13 Janvier 2012

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

Re les filiens et filiennes

Reconstruction de NBJourOuvre pour ne pas faire trente-six fois les même calculs et correction de la condition.
la function Fer a légèrement été modifiée pq= clng(Paq(an))

Code:

Function NBJoursOuvres(D1 As Date, D2 As Date)
    Dim I As Long, j As Integer
    Dim ChaineFériés As String
    Dim IsFerie As Boolean
    an = 0
    For I = D1 To D2
        'En cas de changement d'année en cours de période
        If an <> Year(I) Then
            an = Year(I)
            ChaineFériés = Join(Fer(an))
        End If
        'Est-ce férié
        IsFerie = InStr(1, ChaineFériés, CStr(I)) > 0
        
        NBJoursOuvres = NBJoursOuvres + ((Weekday(CDate(I)) <> 1 And _
                                         Weekday(CDate(I)) <> 7) And Not IsFerie) * -1
    Next
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(ByVal an As Integer)    '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

[Edit] changement d'année en cours de période pris en compte.

A+

CyberNeo99 · 13 Janvier 2012

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

Bonjour à tous,

Avec Excel 2003 cela peut se faire via une formule mais par contre il faut activer le module de macro complémentaire. Pour l'activer il faut aller dans le menu options et ensuite macros Complémentaires et activer Analysys Toolpak. La fonctionn s'appele Workday. Le seul problème si une autre personne ouvre le fichier en question et que ce module n'est pas activer la fonction ne fonctionnera pas. Pour se faire il faut insérer un code VBA dans ThisWorkBook qui va aller activer au démarrage du fichier le module de Macros Complémentaires Analysys ToolPak.

Voici le code VBA pour activer le module de Macros Complémentaires

AddIns("Utilitaire d'analyse").Installed = True
AddIns("Analysis ToolPak").Installed = True

À insérer dans ThisWorkBook

Neo

Guest · 13 Janvier 2012

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

Re,

@Cyberneo apparament le but est justement de ne pas faire appel à Serie.Jour.Ouvre ou WorkDay de l'utilitaires d'analyse.

A+

C@thy · 13 Janvier 2012

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

Merci a vous tous et tout particulièrement Hasco
Jolie trouvaille pour ne pas répéter 36 fois la même chose Merci à toi de l'avoir vu!

Chapeau l'artiste! Merci d'avoir revisité ma fonction fer, je l'avais modifiée suite à tes conseils et remarques fort justes et qui m'ont fait progresser.

Un super grand MERCI Ges. Effectivement le but était d'éviter la macro complémentaire (bien vu!

)

Bises

C@thy

C@thy · 3 Janvier 2014

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

Bonjour les zamis,

je cherche à tester (en vba) si la date du jour est le premier jour ouvré de l'année, hors week-end et féries.

A partir de toutes les données de ce fil, je ne suis pas arrivée à mon résultat.

J' ai par ailleurs déduit que le 1er jour ouvré de l'année est soit :
le lundi 2 le mardi 2 le mercredi2 le jeudi 2 le vendredi 2 le lundi 3 le lundi 4, pas vrai?

Ce serait donc plus facile pour écrire la macro, pas besoin de la liste des fériés...

Si quelqu'un peut m'aider, je l'en remercie vivement par avance.

Bises

C@thy

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

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Guest

Guest

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Guest

Guest

XLDnaute Occasionnel

Guest

Guest

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Partager cette page

Statistiques des forums