XL 2016 Cherche code vba pour récupérer des dates

[Anais0998]

Bonjour à tous,

Je cherche depuis quelques jours sans trouver la solution j'espère pouvoir trouver de l'aide parmi vous.

Grâce à des codes trouvés sur le net, j'ai réussi à mettre en place ce petit calendrier perpétuel, qui, grâce au code que j'ai posté plus bas, me renvoie, lorsque je clique dans la cellule (date) du calendrier, la date complète dans la cellule indiquée dans le code.

Ce que j'ai besoin d'obtenir, c'est 4 dates complètes. Donc comment pourrait-on faire en sorte qu'en cliquant sur les différentes cellules à la suite, chaque date soit renvoyée dans des cellules précisées dans le code.
Je vous remercie d'avance pour votre aide précieuse, bonne journée à tous.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Sheets("ACCUEIL2")
If Not Intersect(Target, Range("B13:H18")) Is Nothing Then
Range("D22").Value = Target.Value
End If
End With
End Sub

 

[Anais332*192]

Re

A tester (il y a probablement des cas non prévus !!)
Mais j’espère que Gerard pourra mettre en place sa solution

Bonjour pierrejean et mrci pour ton aide. J'ai testé le fichier, alors en changeant de mois, les mefc des cellules déjà sélectionnées s'effacent bien, malheureusement, dès que l'on sélectionne à nouveau une date dans le mois suivant, les autres cellules réapparaissent, du coup ça ne va pas. Comme je disais à job75, je pense que je vais laisser tomber cette option, c'était juste pour avoir un visuel des dates de formation qui peuvent aller de 1 à 4 jours, le soucis étant que souvent les dates s'étalent d'un mois voire d'une année à l'autre, et ça complique tout. Pour ma part je vais continuer de chercher, je suis têtue et j'aime bien arriver à mes fins ... Donc si une autre idée te passe par la tête, je suis preneuse. Encore merci bcp.

 

[job75]

Bonjour Anais332*192, Pierre;

Bon voyez le fichier joint et ce code :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim o As Object
If Intersect(ActiveCell, [B13:H18]) Is Nothing Then Exit Sub
Set o = DrawingObjects("Rectangle : coins arrondis 33")
If UBound(Split(o.Text, " - ")) = 3 Then o.Text = "": Exit Sub
If ActiveCell <> "" Then o.Text = IIf(o.Text = "", "", o.Text & " - ") & Format(ActiveCell, "dd/mm/yy")
End Sub

Sub RAZ()
'se lance en cliquant sur "Date(s) de formation"
DrawingObjects("Rectangle : coins arrondis 33").Text = ""
End Sub

Cliquer sur "Date(s) de formation" pour effacer les dates du rectangle.

Bonne journée.

 

[Anais332*192]

Bonjour Anais332*192, Pierre;

Bon voyez le fichier joint et ce code :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim o As Object
If Intersect(ActiveCell, [B13:H18]) Is Nothing Then Exit Sub
Set o = DrawingObjects("Rectangle : coins arrondis 33")
If UBound(Split(o.Text, " - ")) = 3 Then o.Text = "": Exit Sub
If ActiveCell <> "" Then o.Text = IIf(o.Text = "", "", o.Text & " - ") & Format(ActiveCell, "dd/mm/yy")
End Sub

Sub RAZ()
'se lance en cliquant sur "Date(s) de formation"
DrawingObjects("Rectangle : coins arrondis 33").Text = ""
End Sub

Cliquer sur "Date(s) de formation" pour effacer les dates du rectangle.

Bonne journée.

Bonjour et merci Job75, tu as fait du bon boulot malheureusement ce n'est toujours pas ce que je recherche.

J'abandonne pour le moment car je dois avancer dans mon fichier.

Bonne soirée et certainement à bientôt.

 

[Anais0998]

Bonjour Job75 et pierrejean, je ne trouve pas comment faire pour mettre mon post au statut "résolu". Si quelqu'un peut m'orienter svp. Merci d'avance.