Comment ajouter des jours ouvrés à un DTPicker ?

[dmoluc]

Re Bonsoir tout le monde

Le problème est un peu plus ardu cette fois-ci : j'ai 2 DTPicker sur un userform et en modifiant la date du premier et en y ajoutant des jours ouvrés, je veux que le second DTPicker change comme si on lui avait ajouté des jours calenders

dans excel avec une formule pas de problème, alors j'ai essayer de transcrire sans grand succés en VBA

Private Sub DTPicker1_change()
DTPicker2.Value = WorkDay(DTPicker1.Value, TextBox113.Value, Sheets("Feuil1").Range("B2:B12"))
End Sub

la TextBox113.Value = jours ouvrables

la feuille et la plage des jours fériés autres que samedi et dimanche : Sheets("Feuil1").Range("B2:B12")

Merci pour votre aide car là je sèche vraiment

 

[dmoluc]

Re : Comment ajouter des jours ouvrés à un DTPicker ?

Bonjour à tous,

la nuit m'a apportée une solution : je me suis dit, si je sais le faire avec une formule je n'ai qu'à compiler le VBa et les formule. Ce n'est sans doute pas le top car cela me fait une feuille de plus dans mon classeur qui est déjà très chargé, mais ça marche 😉 alors pour ceux que ça intéresse, je mets la solution d'autant plus qu'elle est simple

Private Sub DTPicker1_change()
'j'impute la valeur du DTPicker1 à la cellule A16 de ma feuille excel
Sheets("Feuil1").Range("A16") = DTPicker1.Value
'Je récupère la valeur calculée sur la feuille excel pour l'affichée dans le DTPicker2
Me.DTPicker2.Value = Sheets("Feuil1").Range("B16").Value
End Sub

Sur ma feuille de calcul plage B2:B12 = Jour fériés 2012, C2:C12 = jour férié 2013 etc.... l'inconvégniant de cette méthode est qu'il va falloir mettre des conditions pour les années dans la macro du dessus

j'inscrit la durée en jour ouvrés à ajouter à la date

Private Sub TextBox113_Change()
Sheets("Feuil1").Range("A17") = TextBox113.Value
End Sub

puis en "B16" je mets cette formule : =SERIE.JOUR.OUVRE($A$16;$A$17;B2:B12)
A16 =Date de départ, A17 = nombre de jours à ajouter, B2:B12 = jour férié pour l'année 2012
Je n'ai plus qu'a recopier la formules vers la droite pour les autres années

Voilà ce que donne mon code pour calculer avec la bonne année :

Private Sub DTPicker1_change()
Ligne = 1
'je recherche le numéro de colonne contenant l'année correspondant à la date de mon DTPicker1
Colonne = Application.Match(Year(Me.DTPicker1) * 1, Rows(1))
Sheets("Feuil1").Range("A16") = DTPicker1.Value
'je n'ai plus qu'à allé chercher la valeur au bon endroit
Me.DTPicker2.Value = Sheets("Feuil1").Cells(Ligne, Colonne).Offset(15, 0).Value
End Sub

Mon programme comporte une faille ! si je suis au mois de Décembre et que les jours ajoutés m'envoient à l'année suivante !!!! et je ne vois pas trop comment gérer ce problème

Si quelqu'un a une idée, elle sera la bienvenue

Cordialement

Didier

 

[dmoluc]

Re : Comment ajouter des jours ouvrés à un DTPicker ?

J'ai été obliger de modifier un peu la macro mais cette fois-ci ça fonctionne très bien, par contre je n'ai toujours pas trouver de solution pour changer d'année lorsque l'on est a cheval sur 2 années

Private Sub DTPicker1_change()
Dim D, Colonne As Long
Ligne = 16
D = Year(Me.DTPicker1)
With Sheets("feuil1")
Colonne = .Range("B1:zz1").Find(D, LookIn:=xlValues, lookat:=xlWhole).Column
.Range("A16") = DTPicker1.Value
Me.DTPicker2.Value = .Cells(Ligne, Colonne).Value
End With
End Sub

 

[Bebere]

Re : Comment ajouter des jours ouvrés à un DTPicker ?

bonjour dmoluc
une fonction de Frédéric Sigonneau

Function PlusJOuvres(D, NbJours)
Dim Dt, i
Dim NbOr, Epacte As Integer
Dim PLune, LPaques, Arr(10) As Long
    
  Dt = CLng(D)
  Do
    Dt = Dt + 1
    'calcul du Lundi de Pâques
    NbOr = (an Mod 19) + 1
    Epacte = (11 * NbOr - (3 + Int(2 + Int(an / 100)) * 3 / 7)) Mod 30
    PLune = DateSerial(an, 4, 19) - ((Epacte + 6) Mod 30)
    If Epacte = 24 Then PLune = PLune - 1
    If Epacte = 25 And (an >= 1900 And an < 2200) Then PLune = PLune - 1
    LPaques = PLune - Weekday(PLune) + vbMonday + 7    'Lundi Paques
    
    'tableau des fériés
    Arr(0) = DateSerial(an, 1, 1)
    Arr(1) = LPaques
    Arr(2) = LPaques + 38  'Ascencion
    Arr(3) = LPaques + 49  'Pentecôte
    Arr(4) = DateSerial(an, 5, 1)
    Arr(5) = DateSerial(an, 5, 8)
    Arr(6) = DateSerial(an, 7, 14)
    Arr(7) = DateSerial(an, 8, 15)
    Arr(8) = DateSerial(an, 11, 1)
    Arr(9) = DateSerial(an, 11, 11)
    Arr(10) = DateSerial(an, 12, 25)
    
    'ajoute si ouvré
    If (IsError(Application.Match(Dt, Arr, 0))) = True And _
        (Weekday(Dt, vbMonday) < 6) = True Then
      i = i + 1
    End If
  Loop Until i = NbJours
  
  PlusJOuvres = Dt

End Function 'fs

exemple d'appel

Sub test()

madate = Format(PlusJOuvres(Date, 6), "dddd dd mmm yyyy")
MsgBox madate

End Sub

à bientôt

 

[dmoluc]

Re : Comment ajouter des jours ouvrés à un DTPicker ?

Merci pour cette fonction, mon bricolage fonctionne bien tant que je ne suis pas à cheval sur 2 années, je vais donc essayer cette fonction va sans aucun doute améliorée mon programme qui est obligé de jongler entre VBA et Formules excel

Merci encore,

Cordialement

Didier