Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not IsNumeric(Sh.Name) Then Exit Sub
Dim c As Range, S As Shape
Application.ScreenUpdating = False
On Error Resume Next
For Each c In Sh.[E:E].SpecialCells(xlCellTypeFormulas)
Set S = Nothing
Set S = Sheets("LISTE").Shapes(c)
If Not S Is Nothing Then
c(1, 0).Select
S.CopyPicture
Sh.Paste
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Width = c(1, 0).Width
Selection.Height = c(1, 0).Height
End If
Next
Application.Goto Sh.[A1], True 'cadrage
ActiveCell.Copy ActiveCell 'vide le presse-papiers
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If Not IsNumeric(Sh.Name) Then Exit Sub
Dim S As Shape
For Each S In Sh.Shapes
If Not Intersect(S.TopLeftCell, Sh.Range("D4:D18")) Is Nothing Then S.Delete
Next
End Sub