XL 2013 copier/coller des images aprés clique sur icone VBA

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
Sh.DrawingObjects.Delete 'RAZ
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 IsNumeric(Sh.Name) Then Sh.DrawingObjects.Delete 'RAZ
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

Sub CrationPNDenPDF()
Dim sNomFichierPDF As String 'pour PDF
Dim i%
'Dim i As Integer   'pour logo et pictogramme
Dim stFeuille As String   'pour logo et pictogramme

''' Logo'''
 Application.ScreenUpdating = False
    Range("C2:D2").Select
    Application.CutCopyMode = False
    Selection.Copy
    
    For i = 3 To Sheets.Count
    Sheets(i).Select
    Range("D1:E1").Select
ActiveSheet.Pictures.Paste(Link:=True).Select
      Range("F1:J1").Select
Next i

    Sheets("Sommaire").Select
    Application.CutCopyMode = False
    Range("B2").Select
    
Application.ScreenUpdating = True ' a supp?
''' Logo'''

''' duplication des pictogramme'''
    Sheets("LISTE").Select
 Application.ScreenUpdating = False
    Range("C201").Select
    Application.CutCopyMode = False
    Selection.Copy
    
    For i = 3 To Sheets.Count
    Sheets(i).Select
    Range("B2").Select
ActiveSheet.Pictures.Paste(Link:=True).Select
      Range("F1:J1").Select
Next i

    Sheets("Sommaire").Select
    Application.CutCopyMode = False
    Range("B2").Select
    
    
'''PDF'''
If Sheets.Count < 3 Then Exit Sub

Sheets(3).Select
For i = 3 To Sheets.Count
    Sheets(i).Select False 'sélection multiple
Next
ActiveSheet.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & Range("Sommaire!B51").Value
Sheets(3).Select
'''PDF'''

    
    
Application.ScreenUpdating = True
    MsgBox "La création des PND est terminée. BRAVO !", vbInformation, "P.N.D."
End Sub