Recherche date en fonction d'une date de départ et d'une durée VBA
Bonjour,
Je suis face à une problématique que je n'arrive pas à résoudre. J'ai crée un formulaire excel permettant à l'utilisateur, à partir d'une date de départ qu'il définit, de calculer la date d'échéance en écrivant la durée dans une cellule et inversement de calculer la durée en écrivant la date d'échéance dans une autre cellule à l'aide d'un code vba cependant j'aimerais que la date d'échéance ne tombe jamais un samedi ou dimanche sans exclure tous les samedis et dimanche. Par exemple, je voudrais que si le 13/11/2020 je remplis le formulaire avec une durée de 1 an, la date d'échéance prennent en compte que le 13/11/2021 est un samedi et que la date du lundi 15/11/2021 soit mise automatiquement. J'ai pensé à utiliser la fonction JOURSEM en vba mais je ne sais pas trop comment l’insérer.
Le code actuel ressemble à ça :
Dim Echéance As Range
Dim Durée As Range
Set Echéance = Range("F11")
Set Durée = Range("F14")
If Not Application.Intersect(Echéance, Range(Target.Address)) _
Is Nothing Then
Range("F14").Value = (Echéance - Range("F8").Value) / 360
End If
If Not Application.Intersect(Durée, Range(Target.Address)) _
Is Nothing Then
Range("F11").Value = DateAdd("yyyy", Durée, Range("F8").Value)
End If
Cordialement,
Jey
Salut Jey,
Une histoire de DATEDIFF(), ça mais, ce serait gentil de...
A+
Salut,
Voici le fichier. Je voudrais que si je rentre une durée et que la date d'échéance tombe un jour de weekend elle soit automatiquement décalé au lundi qui suit.
Merci par avance.
UP svp !
J'ai trouvé un début de solution avec :
Else: If Weekday(Cells(11, 6), vbMonday) = 6 Then Range("F11").Value = Worksheets("Feuil1").Cells(11, 6).Value + 2
Ce qui me permet de décaler à lundi au cas ou la date tombe un samedi cependant ma macro se transforme en boucle infinii car elle recalcule la durée pour la remettre à samedi puis le if remet la date à lundi et tout ça à répétition sans arrêt. Que-faire ? Je ne sais pas si je suis clair dans mon explication.
Merci.
Salut Jey,
déso, je t'avais presque oubliée
En VBA, lorsqu'il s'agit de l'événementielle Worksheet_Change(), lorsque la cellule en cause est susceptible d'être... Changée par la macro elle-même, comme dans ce cas-ci, ne JAMAIS oublier d'ajouter Application.EnableEvents = False afin de neutraliser le rappel de cette même événementielle à l'infini...
Également, si tu ne veux pas un programme inerte en sortant de cette procédure, ne JAMAIS oublier d'ajouter, en fin de procédure Application.EnableEvents = True !!
Private Sub Worksheet_Change(ByVal Target As range)
'
Application.EnableEvents = False
'
If Not Intersect(Target, [F11]) Is Nothing Then _
[F11] = DateAdd("d", IIf(Weekday(CDate([F11]), vbMonday) > 5, 8 - Weekday(CDate([F11]), vbMonday), 0), CDate([F11])): _
[F14] = CInt(DateDiff("yyyy", CDate([F8]), CDate([F11])))
'
Application.EnableEvents = True
'
End Sub
A+
Merci pour la réponse. Cependant de cette manière l'échéance ne peut plus être calculé à partir de la durée. Le fichier de base me permet de calculer la durée à partir de l'échéance et l'échéance à partir de la durée pour permettre à l'utilisateur de rentrer la donné qu'il préfère.
Salut Jey,
devrait être réparé...
La durée se calcule depuis la date en [F11] et la date en [F11] se calcule depuis la durée.
Private Sub Worksheet_Change(ByVal Target As range)
'
Dim dDate As Date
Application.EnableEvents = False
'
If Not Intersect(Target, [F11]) Is Nothing Then _
[F14] = CInt(DateDiff("yyyy", CDate([F8]), CDate([F11]))): _
[F11] = DateAdd("d", IIf(Weekday(CDate([F11]), vbMonday) > 5, 8 - Weekday(CDate([F11]), vbMonday), 0), CDate([F11]))
'
If Not Intersect(Target, [F14]) Is Nothing Then _
dDate = DateAdd("yyyy", CInt([F14]), CDate([F8])): _
[F11] = DateAdd("d", IIf(Weekday(dDate, vbMonday) > 5, 8 - Weekday(dDate, vbMonday), 0), dDate)
'
Application.EnableEvents = True
'
End Sub
A+
Salut Jey,
j'y retravaillerai en soirée : le résultat actuel ne me plaît pas beaucoup...
Exemple : si tu encodes une valeur non conforme ou si tu effaces la donnée = catastrophe !
A+
C'est gentil, merci. Et on ne peut pas entrer des durées avec décimal. J'avais déjà ce problème dans mon fichier. J'aimerais pouvoir mettre 1,5 an et que ça calcule précisément la date d'échéance et inversement si c'est faisable.
Je regarde ça tout à l'heure
A+
Salut Jey,
après réflexion, je préconise un encodage de la durée en MOIS : plus simple, facile, sans pièges !
Le calcul de ces durées ne devrait, j'imagine, pas te poser trop de problèmes !
- l'encodage en [F11] ou [F14] efface l'affichage de la cellule-miroir ;
- ainsi, si la valeur encodée est vide, pas de souci ;
- si [F11] est vide, sa sélection affiche par défaut la date en [F8] + 12 mois : l'idée est d'afficher la durée la plus fréquemment utilisée.
On peut imaginer placer cette valeur-défaut quelque part, modifiable...
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim dDate As Date, iM%
Application.EnableEvents = False
'
If Not Intersect(Target, Union([F11], [F14])) Is Nothing Then
Range("F" & IIf(Target.Row = 11, 14, 11)).Value = ""
If Target <> "" Then
If Target.Row = 11 Then _
[F14] = CInt(DateDiff("m", CDate([F8]), CDate([F11]))): _
dDate = CDate([F11])
If Target.Row = 14 Then dDate = DateAdd("m", CInt(Target), CDate([F8]))
[F11] = DateAdd("d", IIf(Weekday(dDate, vbMonday) > 5, 8 - Weekday(dDate, vbMonday), 0), dDate)
End If
End If
'
Application.EnableEvents = True
'
End Sub
A+
Merci Cirulis, c'est ce qu'il me fallait :).
Salut Curulis,
Je reviens vers toi pour savoir si il est possible d'intégrer les durée avec décimal dans ce code ? Je n'arrive pas a voir pour quel raison les décimal ne sont pas prit en compte. DateAdd ne le permet pas ? J'aimerais avoir la possibilité d’écrire 12,5 dans la durée et qu'il calcul précieusement à quel date cela correspond. Inversement, si j'entre une échéance, par exemple, à un an et 15 jours de la date de départ qu'il me calcul précisément la durée. Cette précision est indispensable car la durée permet par la suite de calculer des taux.
Merci par avance.
Salut Jey,
vous calculez des échéances au jour près ? Pas compliqués chez vous...
Question de facilité, plutôt que des décimales, que dirais-tu d'écrire cela ainsi :
- 12+15 = 12 mois et 15 jours = 1 an et 15 jours ;
- 0+25 = dans 25 jours ;
- 24 = 24 mois
A+
Oui au jour près. Quoiqu'il en soit les données peuvent être rentré en dur donc ce n'est pas indispensable mais si il y a une solution possible je suis preneur. Oui ça peut être intéressant d'écrire cela ainsi :D
Salut Jey,
m'a l'air bien...
Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim dDate As Date, iM%, iD%
Application.EnableEvents = False
'
If Not Intersect(Target, Union([F11], [F14])) Is Nothing Then
Range("F" & IIf(Target.Row = 11, 14, 11)).Value = ""
If Target <> "" Then
'si chgt dans [F11] = cellule date
If Target.Row = 11 Then dDate = [F11]
'si chgt dans [F14] = Mois + jours
If Target.Row = 14 Then _
dDate = DateAdd("m", CInt(Split([F14], "+")(0)), [F8]): _
If InStr([F14], "+") > 0 Then dDate = DateAdd("d", CInt(Split([F14], "+")(1)), dDate)
'calcul du déplacement éventuel si dDate = WE
iD = IIf(Weekday(dDate, vbMonday) > 5, 8 - Weekday(dDate, vbMonday), 0)
If iD > 0 Then [F11] = DateAdd("d", iD, dDate)
'calcul de la durée à afficher en [F14]
iD = 0
iM = DateDiff("m", [F8], [F11])
If Day([F8]) > Day([F11]) Then iM = iM - 1
If Day([F8]) <> Day([F11]) Then _
dDate = DateAdd("m", iM, [F8]): _
iD = DateDiff("d", dDate, [F11])
[F14] = iM & IIf(iD = 0, "", "+" & iD)
End If
End If
'
Application.EnableEvents = True
'
End Sub
A+
Sur le fichier téléchargé les calculs ne fonctionnent pas malheureusement :(
Salut Jey,
déso, j'avais trouvé intelligent d'ajouter un IF en fin de test... sans vraiment encore essayer ensuite d'en voir les effets...
A+
La c'est parfait, je vais pouvoir l'adapter en mois + jour ou en année + mois selon les besoins du coup.
Encore merci :D