Décallage de date dynamique
Bonjour à tous,
un problème de date sur Excel Vba j'ai (voilà que je parle comme maitre Yoda
le fichier est relativement simple mais je voudrais pouvoir l'améliorer,
en pièce jointe un extrait du fichier.
sur les colonnes A à M : On a un calendrier qui est remplis à partir du tableau en colonne O à R
la question est la suivante, pour la partie remplissage dynamique à partir de la base de donnée pas de soucis, par contre en réfléchissant il serait pratique de pouvoir décaller les date si une urgence arrive.
Exemple :
la base de donnée est la suivante (cf fichier)
debut fin nom salarié 1
15/01/2018 18/01/2018 Escaler Salarié 1
20/01/2018 22/01/2018 Portail Salarié 1
23/01/2018 26/01/2018 Porte Salarié 1
si on a un nouveau chantier urgent en date du 20/01 et que le chantier dure 2 jours, il faudra alors décaler les dates des autres chantiers d'autant de jours que necessaire. (soit 2 jours)
Si on a un nouveau chantier le 15/01/2018(durée 3 jours), il faudra alors décaler :
le chantier escalier de 3 jours soit du 18 janvier au 21 janvier
le portail du 21 janvier au 23 janvier
la porte du 24 janvier au 26 janvier,
en espérant être relativement clair
bien à vous et un grand merci pour vos lectures commentaires, accompagnement vers la solution
cordialement
Edouard002
Salut Edouard,
voici une macro qui fera le travail.
Tu peux aussi bien insérer une nouvelle ligne pour un nouveau chantier que changer la date de fin d'un chantier existant.
La correction est automatique.
Ne convient que pour ton exemple : à modifier si ton tableau BDD est ailleurs.
NOTE : après vérification des dates de l'exemple, je n'ai pas tenu compte des jours ouvrables pour calculer les dates de début de chantier.
Private Sub Worksheet_Change(ByVal Target As Range)
'
Application.EnableEvents = False
'
If Not Intersect(Target, Range("O:P")) Is Nothing Then
If Range("O" & Target.Row).Value <> "" And Range("P" & Target.Row).Value <> "" Then
For x = Target.Row + 1 To Range("O" & Rows.Count).End(xlUp).Row
If CDate(Cells(x - 1, 16)) >= CDate(Cells(x, 15)) Then _
iDiff1 = DateDiff("d", CDate(Cells(x, 15)), CDate(Cells(x, 16))): _
Cells(x, 15) = DateAdd("d", 1, CDate(Cells(x - 1, 16))): _
Cells(x, 16) = DateAdd("d", iDiff1, CDate(Cells(x, 15)))
Next
End If
End If
'
Application.EnableEvents = True
'
End SubA+
Bonjour curulis57
un grand merci à toi, je vais etudier ton code avec la plus grande attention.
Bien COrdialement
Edouard002
Re,
je viens de tester le code, et il semble que la solution ne prenne pas en compte un cas à moins que ce soit normal
je me permet de te mettre le fichier où j'ai intégré ta macro
encore merci pour le coup de main
cdt
edouard002
Salut Edouard,
en effet, je n'ai pas pensé une seconde que ce nouveau chantier pouvait être encodé en dernière ligne mais uniquement en insertion DANS le tableau.
Je regarde ça...
A+
Salut Edouard,
essaie ceci.
Les nouveaux chantiers DOIVENT maintenant (pas de flingue, hein!
Vu l'heure, je n'ai pas scanné toutes les possibilités potentielles d'emberlificotage de dates de chantier.
Je me contente de permettre l'insertion d'un chantier dont le début, au moins, est cohérent avec une date de fin de chantier précédent.
Bref, c'est sans doute sujet à complications inattendues... à résoudre plus tard!
Private Sub Worksheet_Change(ByVal Target As Range)
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("O:P")) Is Nothing Then
iTRow = Target.Row
If Range("O" & Target.Row).Value <> "" And Range("P" & Target.Row).Value <> "" Then
If iTRow = Range("O" & Rows.Count).End(xlUp).Row Then
Cells(iTRow, 15).Resize(1, 4).Borders.LineStyle = xlContinuous: _
For x = Cells.Find(what:="Début", lookat:=xlWhole).Row + 1 To iTRow - 1
If CDate(Cells(iTRow, 16)) < CDate(Cells(x, 16)) Then _
Cells(x, 15).Resize(1, 4).Insert shift:=xlDown: _
Cells(iTRow + 1, 15).Resize(1, 4).Cut Cells(x, 15).Resize(1, 4): _
iTRow = x + 1: Exit For
Next
End If
For y = iTRow To Range("O" & Rows.Count).End(xlUp).Row
If CDate(Cells(y - 1, 16)) >= CDate(Cells(y, 15)) Then _
iDiff1 = DateDiff("d", CDate(Cells(y, 15)), CDate(Cells(y, 16))): _
Cells(y, 15) = DateAdd("d", 1, CDate(Cells(y - 1, 16))): _
Cells(y, 16) = DateAdd("d", iDiff1, CDate(Cells(y, 15)))
Next
End If
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End SubA+
Re Bonsoir,
pas de soucis, un grand merci, pour info, c'est plus des missions de réparation
je vais tester cela
encore merci
Cordialement
Edouard002
Salut Edouard,
version améliorée mais ne prenant toujours en compte que des cas "cohérents", c-à-d, par exemple, des nouveaux chantiers dont la date de début est ultérieure à la date de fin du chantier précédent.
Je me rends compte qu'il y a moyen de jouer les prolongations sur ce truc et je n'en ai malheureusement pas le temps pour l'instant.
Si nécessaire, rappelle-moi dans quelques semaines, le temps de dégager le terrain devant moi.
Private Sub Worksheet_Change(ByVal Target As Range)
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("O:P")) Is Nothing Then
iTRow = Target.Row
If Range("O" & Target.Row).Value <> "" And Range("P" & Target.Row).Value <> "" Then
If iTRow = Range("O" & Rows.Count).End(xlUp).Row Then
Cells(iTRow, 15).Resize(1, 4).Borders.LineStyle = xlContinuous: _
For x = Cells.Find(what:="Début", lookat:=xlWhole).Row + 1 To iTRow - 1
If CDate(Cells(iTRow, 16)) < CDate(Cells(x, 16)) Then _
Cells(x, 15).Resize(1, 4).Insert shift:=xlDown: _
Cells(iTRow + 1, 15).Resize(1, 4).Cut Cells(x, 15).Resize(1, 4): _
iTRow = x: Exit For
Next
End If
For y = iTRow + 1 To Range("O" & Rows.Count).End(xlUp).Row
If CDate(Cells(y, 15)) <= CDate(Cells(y - 1, 16)) Then _
iDiff1 = DateDiff("d", CDate(Cells(y, 15)), CDate(Cells(y, 16))): _
If CDate(Cells(y, 15)) <= CDate(Cells(y - 1, 16)) Then _
Cells(y, 15) = DateAdd("d", 1, CDate(Cells(y - 1, 16))): _
Cells(y, 16) = DateAdd("d", iDiff1, CDate(Cells(y, 15)))
Next
End If
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End SubA+