Resim Çağırırken Üstüne Yazma

arkadaşlar bir konuda yardımcı ihtiyacım var

konuyu şöyle özetliyim
elimde 1500 personelin resimleri bir klasör içerisinde png uzantılı olarak mevcut
ben bu personellere personel giriş kartı yapıyorum ve bunu excel de değer değiştirme düğmesine makro ekleyerek personel bilgileri değiştikçe resimler değişecek şekilde ayarladım ve her seferinde 8 personelin kimliğini oluşturuyorum aynı anda

ancak sorunum şu
birinci grupta resimler istediğim gibi geliyor
ikinci seferde değer değiştirme butonuna basınca bilgiler değişiyor, eski resim silinip yeni resim geliyor buda normal
üçüncü seferde yine tuşa basınca bilgiler değişiyor bu sefer hücrede bulunan resmi silmeden üstüne resim yazıyor.
bir iki tur yine bu şekilde yapıp sonra silip yazıyor. bunu
şöyla açıklayım
1-2 silerek yazıyor
3-4-5 üstüne yazıyor
6-7 silerek yazıyor
8-9-10 üstüne yazıyor

tabi resimler üst üste bindiği içinde sıkıntı oluyor
ekte size makro kodunu gönderiyorum hatanın nerde olduğunuz bana söyleyebilirseniz çok sevinirim

Sub DeğerDeğiştirici2_Değiştir()


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg1 As Range
Dim xRg2 As Range
Dim xRg3 As Range
Dim xRg4 As Range
Dim xRg5 As Range
Dim xRg6 As Range
Dim xRg7 As Range
Dim xRg8 As Range

Application.ScreenUpdating = False
Set xRg1 = Range("H20")
Set xRg2 = Range("W20")
Set xRg3 = Range("H39")
Set xRg4 = Range("W39")
Set xRg5 = Range("H58")
Set xRg6 = Range("W58")
Set xRg7 = Range("H77")
Set xRg8 = Range("W77")

For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg1, xPicRg) Is Nothing Then xPic.Delete
If Not Intersect(xRg2, xPicRg) Is Nothing Then xPic.Delete
If Not Intersect(xRg3, xPicRg) Is Nothing Then xPic.Delete
If Not Intersect(xRg4, xPicRg) Is Nothing Then xPic.Delete
If Not Intersect(xRg5, xPicRg) Is Nothing Then xPic.Delete
If Not Intersect(xRg6, xPicRg) Is Nothing Then xPic.Delete
If Not Intersect(xRg7, xPicRg) Is Nothing Then xPic.Delete
If Not Intersect(xRg8, xPicRg) Is Nothing Then xPic.Delete



On Error GoTo 1
Next
Application.ScreenUpdating = True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

1:
Dim ResimYolu As Variant
Dim Resim As Object


If Range("C1") = "" Then
Exit Sub

End If

ResimYolu = ActiveWorkbook.Path & "\" & Range("C1").Value & ".png"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("H20")
Resim.Height = .Height
Resim.Top = .Top
Resim.Left = .Left
Resim.Width = .Width
Resim.Placement = xlMoveAndSize
End With



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
2:

If Range("C2") = "" Then
Exit Sub
End If
On Error GoTo 2

ResimYolu = ActiveWorkbook.Path & "\" & Range("C2").Value & ".png"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
With Range("W20")
Resim.Height = .Height
Resim.Top = .Top
Resim.Left = .Left
Resim.Width = .Width
Resim.Placement = xlMoveAndSize
End With



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
3:

If Range("c3") = "" Then
Exit Sub
End If
On Error GoTo 3

ResimYolu = ActiveWorkbook.Path & "\" & Range("c3").Value & ".png"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("h39")
Resim.Height = .Height
Resim.Top = .Top
Resim.Left = .Left
Resim.Width = .Width
Resim.Placement = xlMoveAndSize
End With



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
4:

If Range("c4") = "" Then
Exit Sub
End If
On Error GoTo 4

ResimYolu = ActiveWorkbook.Path & "\" & Range("c4").Value & ".png"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("w39")
Resim.Height = .Height
Resim.Top = .Top
Resim.Left = .Left
Resim.Width = .Width
Resim.Placement = xlMoveAndSize
End With



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
5:

If Range("c5") = "" Then
Exit Sub
End If
On Error GoTo 5

ResimYolu = ActiveWorkbook.Path & "\" & Range("c5").Value & ".png"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("h58")
Resim.Height = .Height
Resim.Top = .Top
Resim.Left = .Left
Resim.Width = .Width
Resim.Placement = xlMoveAndSize
End With


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
6:

If Range("c6") = "" Then
Exit Sub
End If
On Error GoTo 5

ResimYolu = ActiveWorkbook.Path & "\" & Range("c6").Value & ".png"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("w58")
Resim.Height = .Height
Resim.Top = .Top
Resim.Left = .Left
Resim.Width = .Width
Resim.Placement = xlMoveAndSize
End With


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
7:

If Range("c7") = "" Then
Exit Sub
End If
On Error GoTo 5

ResimYolu = ActiveWorkbook.Path & "\" & Range("c7").Value & ".png"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("h77")
Resim.Height = .Height
Resim.Top = .Top
Resim.Left = .Left
Resim.Width = .Width
Resim.Placement = xlMoveAndSize
End With


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
8:

If Range("c8") = "" Then
Exit Sub
End If
On Error GoTo 5

ResimYolu = ActiveWorkbook.Path & "\" & Range("c8").Value & ".png"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("w77")
Resim.Height = .Height
Resim.Top = .Top
Resim.Left = .Left
Resim.Width = .Width
Resim.Placement = xlMoveAndSize
End With




'


End Sub