XL 2021 coller une image interne au classeur

[Jouxte]

Bonjour à toutes et tous,

J'utilise du code du regretté Jacques Boisgontier que j'ai modifié avec du code de patricktoulon pour l'insertion dans la cellule cible. Ce code se trouve dans la Worksheet.
Il me sert à coller en colonne F l'image correspondant à l'arrondissement de la colonne E.
J'ai nommé les images des arrondissement de la feuille" Ardt" : Paris 1, Paris 2, et ainsi de suite jusqu'à 20.
J'ai une erreur sur la ligne : ActiveSheet.Paste

Cette macro a fonctionné pour les 6 ou 7 premières lignes.

Par ailleurs, est-il possible de créer une fonction [=CollerImage(Nom de l'image)] qui irait chercher l'image correspondante du classeur pour la coller sur la cellule contenant la formule.

J'ai fait un fichier test avec seulement 4 arrondissements pour qu'il ne soit pas trop lourd.
Merci par avance.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ratio#, W#, H#
If Target.Column = 5 And Target.Count = 1 Then
'-- suppression
For Each S In ActiveSheet.Shapes
If S.Type = 13 Then
If S.TopLeftCell.Address = Target.Offset(0, 1).Address Then
S.Delete
End If
End If
Next S
'--
If Target <> "" Then
Sheets("Ardt").Shapes(Target).Copy
Target.Offset(0, 1).Select
ActiveSheet.Paste

With Selection
.ShapeRange.LockAspectRatio = msoTrue ' lock leratio indéformable
ratio = .Width / .Height ' calcul ratio
W = ActiveCell.Width ' width range
H = ActiveCell.Height ' height range
If (W / H < ratio) Then
.Width = W - 2 'en redimentionant le width le height se redimentionne automatiquement
Else 'ou
.Height = H - (2 / ratio) 'en redimentionant le height le width se redimentionne automatiquement
End If
.Left = ActiveCell.Left + ((ActiveCell.Width - .Width) / 2) + 1
.Top = ActiveCell.Top + ((ActiveCell.Height - .Height) / 2)
.Placement = 1
End With

Target.Select

End If
End If
End Sub

 

[patricktoulon]

re Bonjour @Jouxte
je viens de m’apercevoir que tu a des listes de validation(qui n'etaient pas dans ton exemple déposé
le bouton de liste de validation est une shape aussi (de type 8 même)
qu'il ne faut bien evidemment pas toucher) et qui est non supprimable voila ou est ton erreur
donc fort de cette constatation

'patricktoulon
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim s As Shape, cible As Range, Ratio
    If Target.Column = 5 And Target.Count = 1 Then
        Set cible = Target.Offset(, 1)
        '-- suppression
        If ActiveSheet.Shapes.Count > 0 Then
            For Each s In ActiveSheet.Shapes
              If s.Type <> 8 Then If s.TopLeftCell.Row = Target.Row Then s.Delete
            Next s
        End If
        '--
        If Target <> "" Then
            On Error Resume Next 'au cas ou un tape un chiffre qui ne correspond pas il n'y aura pas de shape donc erreur
            Sheets("Ardt").Shapes(Target.Text).CopyPicture

            If Err.Number > 0 Then
                Err.Clear 'donc en cas d'erreur bye bye
                MsgBox "y a pas de shapes (" & Target.Text & ")"
                Exit Sub
            End If
            Target.Offset(, 1).Select
           
            With Target.Parent
                .Pictures.Paste
                Set Shap = .Shapes(Shapes.Count - 1)
                Ratio = Application.Min(((cible.Width)) / Shap.Width, ((cible.Height)) / Shap.Height)
                With Shap
                    .LockAspectRatio = msoTrue
                    .Width = (.Width * Ratio)
                    .Top = cible.Top + ((cible.Cells(1).MergeArea.Height - (.Height - 2)) / 2)
                    .Left = cible.Left + ((cible.Cells(1).MergeArea.Width - (.Width - 2)) / 2)
                    '.Placement = 1
                End With
            End With
        End If
    End If
End Sub

à l'avenir dépose un fichier exemple conforme à l'original en terme d'object ,on perdra moins de temps
cordialement patrick

 

[Jouxte]

Re,
Merci Patrick !
"à l'avenir dépose un fichier exemple conforme à l'original en terme d'object ,on perdra moins de temps"
Je ne pensais pas que ça puisse interférer. Désolé.
avec ce nouveau code j'ai des choses curieuses
j'ai supprimé la liste de validation.

 

[patricktoulon]

re
punaise tu le fait exprès toi
si tu a des listes de validation c'est shapes.count-1 sinon c'est shapes.count
modifie la formule dans la liste de validation pour supprimer les blancs chez moi avec decaler ça ne fonctionne pas

 

[Jouxte]

Bonjour Patrick,
J'ai encore des choses curieuses.
Je pense que je ne suis pas parti sur la bonne piste avec mon code initial que tu as largement modifié.
Peut-on créer une macro qui dise :
Quand je valide une cellule de la colonne E si ce nom correspond au nom d'une image du classeur, alors colle là dans la cellule voisine de la colonne F sinon "".
Par avance merci pour tes réponses toujours pertinentes.