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

 

[Jouxte]

voici le fichier.

 

[vgendron]

Bonjour
essaie avec
activesheet.pastespecial

 

[Jouxte]

Bonjour vgendron,
là l'erreur s'est déplacée à
Sheets("Ardt").Shapes(Target).Copy

 

[vgendron]

si tu réponds à ces deux questions, tu as la solution
que vaut target?... comment s'appellent tes images..?

 

[Jouxte]

Target vaut la valeur dans la cellule donc Paris 1 ou Paris 2, et ainsi de suite jusqu'à 20.
et les images s'appellent Paris 1, Paris 2, et ainsi de suite jusqu'à 20.

 

[vgendron]

dans la cellule donc Paris 1 ou Paris 1, Paris 2, et ainsi de suite jusqu'à 20
et bah non...
ajoute un msgbox target pour le savoir

 

[vgendron]

tu as un format personnalisé dans ta colonne E
Ce que tu vois n'est pas ce qui est dans la cellule

 

[Jouxte]

J'ai essayé sans format personnalisé directement avec Paris 1 par exemple.

 

[Jouxte]

As-tu le même problème chez toi en E25 quand tu tapes Paris 10 par exemple

 

[vgendron]

non

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
            Set cible = Target.Offset(0, 1)
            Sheets("Ardt").Shapes("Paris " & Target).Copy
        
            cible.PasteSpecial
    
            With Selection 'il s'agit de l'image qui vient d'être collée
                .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
                ratio = .Width / .Height     ' calcul ratio
                W = cible.Width       ' width  range
                H = cible.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 = cible.Left + ((cible.Width - .Width) / 2) + 1
                .Top = cible.Top + ((cible.Height - .Height) / 2)
                .Placement = 1
            End With
    
            Target.Select
        End If
    End If
End Sub

 

[Jouxte]

Merci pour ta réponse.
Super ça fonctionne.
Pour ma culture personnelle est-il possible de faire une fonction comme évoqué dans mon 1er post ?

 

[vgendron]

surement, mais je ne vois pas comment, et surtout je ne vois pas l'intérêt par rapport au code existant..?

 

[Jouxte]

L'intérêt serait pour un autre fichier. Merci encore.

 

[vgendron]

L'intérêt serait pour un autre fichier. Merci encore.

ca n'empecherait pas de devoir copier le code dans l'autre fichier..