Adapter plusieurs images Excel à une colonne défini

Bonjour au forum,

Je joins un fichier à ma demande, je souhaiterai que lorsque je glisse l'objet "Rectangle à coins arrondis" sur le tableau en colonne P, le format s'adapte à la cellule,

Par exemple, l'image Test s’adapterait à la cellule P4, mais également à la cellule P6,

Merci d'avance pour votre aide,

Cordialement,

Bonjour,

Soient deux shapes (P4_XXXXX) et (P6_YYYYY) dont les noms indiqueraient l'adresse de la cellule avant l'underscore. La condition pour que cela fonctionne, c'est la présence d'une adresse valide et du caractère "_"

Sub PlacerLesShapesDansLesCellules()

Dim I As Integer, J As Integer
Dim CelShape As Range
Dim MaForme As Shape
Dim MaTableDeFormes As Variant

    MaTableDeFormes = Array("P4", "P6")

    With Sheets("TCD GL O E")
         If .Shapes.Count = 0 Then Exit Sub
         For I = 1 To .Shapes.Count
                 For J = LBound(MaTableDeFormes) To UBound(MaTableDeFormes)
                     Set MaForme = .Shapes(I)
                     If Split(MaForme.Name, "_")(0) = MaTableDeFormes(J) Then
                        Set CelShape = .Range(MaTableDeFormes(J))
                        With MaForme
                              .Top = CelShape.Top
                              .Left = CelShape.Left
                              .Width = CelShape.Width
                              .Height = CelShape.Height
                        End With
                        Set CelShape = Nothing
                        Set MaForme = Nothing
                     End If
                 Next J
          Next I
    End With

End Sub

Bonjour Eric Kerjresse,

Merci pour votre retour, je souhaiterai néanmoins préciser ma demande : je ne veux pas que ce soit possible uniquement pour les cellules P4 et P6 mais pour toutes les cellules de la colonne P, et il y aura un nombre variable d'images car c'est un fichier exemple, en réalité j'ai une cinquantaine de cellules dans la colonne P ou je devrais y mettre une image !

Est-ce possible?,

Merci d'avance pour votre aide,

Cordialement,

Oui c'est possible. Il suffirait de mettre une valeur en colonne R par exemple dans les cellules qui doivent recevoir une forme. La font de la colonne R serait de la même couleur que la couleur de fond de la cellule pour cacher les valeurs.

Sub TestPlacerLesShapesDansLesCellules()

    PlacerLesShapesDansLesCellules Sheets("TCD GL O E"), 18, "Modèle"

End Sub

Sub PlacerLesShapesDansLesCellules(ByVal Sh As Worksheet, ByVal ColRef As Integer, ByVal NomFormeModele As String)

Dim Continuer As Boolean
Dim I As Integer, J As Integer, DerniereLigne As Integer, NbShapes As Integer
Dim CelShape As Range
Dim MaForme As Shape, FormeModele As Shape

    With Sh

         DerniereLigne = .Cells(.Rows.Count, ColRef).End(xlUp).Row
         If DerniereLigne = 1 Then Exit Sub:  If .Shapes.Count = 0 Then Exit Sub

         SupprimerLesShapes Sh, "P"

         Continuer = False
         For I = 1 To .Shapes.Count
             If .Shapes(I).Name = NomFormeModele Then
                Set FormeModele = .Shapes(I)
                Continuer = True
             End If
         Next I

         If Continuer = False Then MsgBox "Absence de forme modèle !", vbCritical: Exit Sub

         For I = DerniereLigne To 1 Step -1
             If .Cells(I, ColRef) <> "" Then
                NbShapes = .Shapes.Count
                .Shapes("Modèle").Copy
                .Paste
                Set MaForme = .Shapes(NbShapes + 1)
                With MaForme
                     .Name = "P_" & I
                     Set CelShape = Sh.Range("P" & I)
                     With MaForme
                          .Top = CelShape.Top
                          .Left = CelShape.Left
                          .Width = CelShape.Width
                          .Height = CelShape.Height
                     End With
                     Set CelShape = Nothing
                End With
                Set MaForme = Nothing
             End If
          Next I

          .Cells(1, 1).Activate
    End With

End Sub

Sub SupprimerLesShapes(ByVal Sh As Worksheet, ByVal Chaine As String)

Dim I As Integer

    With Sh
         If .Shapes.Count = 0 Then Exit Sub
         For I = .Shapes.Count To 1 Step -1
             With .Shapes(I)
                  If Split(.Name, "_")(0) = Chaine Then .Delete
             End With
         Next I
    End With

End Sub

Bonjour Eric Kergresse,

Merci beaucoup pour votre retour, et après test cela fonctionne parfaitement, je n'aurai jamais su écrire ce code et pour le coup c'est bien plus pratique pour moi que d'essayer de faire correspondre manuellement la taille de l'image à la cellule,

Bonne journée à vous,

Cordialement,