'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.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
With Target.Parent
.Pictures.Paste
Set Shap = .Shapes(Shapes.Count)
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 - 2) - .Height) / 2)
.Left = cible.Left + (((cible.Cells(1).MergeArea.Width - 2) - .Width) / 2)
.Placement = 1
End With
End With
End If
End If
End Sub