Figer un groupe précis de cellules (Excel 2013)

Option Explicit
Dim nom As String
Dim chemin As String
Dim image As Integer
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
image = ActiveSheet.Shapes.Count
If image > 0 Then
ActiveSheet.Shapes(image).Delete
End If
 chemin = ThisWorkbook.Path & "\Dossierimage\" 'a adapter le nom du dossier jpg
If Not Intersect(Target, Range("B:B")) Is Nothing Then 'a adapter les colonnes
 Selection.Offset(0, -1).Select
 ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then 'a adapter les colonnes
 Selection.Offset(0, -2).Select
ElseIf Not Intersect(Target, Range("A:A")) Is Nothing Then 'a adapter les colonnes
nom = Target.Value
If nom = "" Then Exit Sub
Range("F17:K37").Select 'cellule fusionnées a adapter
InsererImage
 End If
End Sub
 Sub InsererImage()
 Dim myPicture As String, MyRange As Range
 myPicture = chemin & nom & ".JPG"
Set MyRange = Selection
InsertAndSizePic MyRange, myPicture
End Sub
Sub InsertAndSizePic(Target As Range, PicPath As String)
Dim p As Picture
Dim hauteur, largeur As Integer
 Application.ScreenUpdating = False
On Error GoTo EndOfSubroutine:
 Set p = ActiveSheet.Pictures.Insert(PicPath)
 largeur = p.Width
 hauteur = p.Height
With Target
If largeur > hauteur Then 'image portrait ou paysage
        p.Left = .Left
        p.Top = .Top
        p.Width = .Width
        Else
        p.Left = .Left
        p.Top = .Top
        p.Height = .Height
        End If
    End With
EndOfSubroutine:
End Sub

Option Explicit
Dim nom As String
Dim chemin As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Retirerimages 'supprimer image cellules fusionnées
chemin = ThisWorkbook.Path & "\Dossierimage\" 'a adapter le nom du dossier jpg
If Not Intersect(Target, Range("B:B")) Is Nothing Then 'a adapter les colonnes
 Selection.Offset(0, -1).Select
 ElseIf Not Intersect(Target, Range("C:C")) Is Nothing Then 'a adapter les colonnes
 Selection.Offset(0, -2).Select
ElseIf Not Intersect(Target, Range("A:A")) Is Nothing Then 'a adapter les colonnes
nom = Target.Value
If nom = "" Then Exit Sub
Range("F17:K37").Select 'cellule fusionnées a adapter
InsererImage
 End If
End Sub
 Sub InsererImage()
 Dim myPicture As String, MyRange As Range
 myPicture = chemin & nom & ".JPG"
Set MyRange = Selection
InsertAndSizePic MyRange, myPicture
End Sub
Sub InsertAndSizePic(Target As Range, PicPath As String)
Dim p As Picture
Dim hauteur, largeur As Integer
 Application.ScreenUpdating = False
On Error GoTo EndOfSubroutine:
 Set p = ActiveSheet.Pictures.Insert(PicPath)
 largeur = p.Width
 hauteur = p.Height
With Target
If largeur > hauteur Then 'image portrait ou paysage
        p.Left = .Left
        p.Top = .Top
        p.Width = .Width
        Else
        p.Left = .Left
        p.Top = .Top
        p.Height = .Height
        End If
    End With
EndOfSubroutine:
End Sub
Sub Retirerimages()
Dim Sh As Shape
For Each Sh In ActiveSheet.Shapes
    If Sh.TopLeftCell.Address = "$F$17" Then 'a adapter cellules fusionnées
      Sh.Delete
       End If
  Next Sh
End Sub