XL 2021 Recherche solution pour actualiser automatiquement un code VBA

[riton00]

Bonsoir au forum

Je cherche une solution permettant à l'icône "image" d'apparaître automatiquement dans la colonne E lorsque je change de date.

Actuellement, pour effectuer cette action, je dois cliquer sur la cellule correspondante dans la colonne D (par exemple, D7), puis cliquer sur la barre de formule, et enfin appuyer sur Entrée pour faire apparaître l'icône.

Slts

 

[Dranreb]

Bonsoir.
C'est la colonne 3 qu'il faut tester alors, pas la 4 !
Bien sûr ce sera alors Feuil5.Shapes(Target.Offset(, 1).Value) qu'il faudra copier.

 

[riton00]

Bonjour Dranreb

Merci d'avoir essayé de m'aider mais ne pourrais-tu pas me donner le code complet puisque j'ai que des débocages

Slts

 

[Dranreb]

Bonjour.
Voilà :

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Shp As Shape
   If Target.Column = 3 And Target.CountLarge = 1 Then
       '-- suppression
      For Each Shp In Me.Shapes
         If Shp.TopLeftCell.Address = Target.Offset(0, 2).Address Then Shp.Delete: Exit For
         Next Shp
      If Target.Offset(, 1).Value <> "" Then
         Feuil5.Shapes(Target.Offset(, 1).Value).Copy
         Target.Offset(0, 2).Select
         Me.Paste
         CadrerShape Selection.ShapeRange(1), Target.Offset(, 2)
         Target.Select
         End If
      End If
   End Sub
Private Sub CadrerShape(ByVal Shp As Shape, ByVal Rng As Range)
   Shp.Left = Rng.Left + (Rng.Width - Shp.Width) / 2
   Shp.Top = Rng.Top + (Rng.Height - Shp.Height) / 2
   End Sub

 

[fanch55]

Bonjour à tous, pour info

@Dranreb , ta solution sur mon excel se plante fréquemment en erreur 1004 sur le Me.paste ( mais pas en pas à pas ) . J'ai réussi à le résoudre en mettant le paste juste après le copy

        If Target.Offset(, 1).Value <> "" Then
            Target.Offset(0, 2).Select
            Feuil5.Shapes(Target.Offset(, 1).Value).Copy
            Me.Paste
            CadrerShape Selection.ShapeRange(1), Target.Offset(, 2)
            Target.Select
        End If

 

[riton00]

Bonsoir Dranreb, franch55, le Forum

Merci Dranreb pour ton code, chez moi il fonctionne bien mais pas à 100% quand je supprime la date de naissance il me créé un Débocage à la ligne Feuil5.Shapes(Target.Offset(, 1).Value).Copy

Slts

 

[Dranreb]

Mettez On Error Resume Next devant et derrière If Err Then Exit Sub
Ou alors faites en sorte que la formule renvoie un nom de Shape existant quand elle ne trouve rien.

 

[riton00]

Mettez On Error Resume Next devant et derrière If Err Then Exit Sub

Merci ça fonctionne 🤩👍

Slts