VBA Picture insert from directoy in merged cell and scaling

A remake
in a module put

Option Explicit

Sub Treat()
Dim WkPath As String
WkPath = ActiveWorkbook.Path & "\" & "Pictures"
 
Dim PicRg  As Range
    Set PicRg = Range("MyPicture")
Dim WkPicN As String
WkPicN = Range("I13")
Dim WkPic As Picture
Dim H, W

Dim WkRg As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        For Each WkPic In .Pictures
            Set WkRg = .Range(WkPic.TopLeftCell.Address & ":" & WkPic.BottomRightCell.Address)
            If Not Intersect(WkRg, PicRg) Is Nothing Then WkPic.Delete
        Next
    End With

    
    Set WkPic = ActiveSheet.Pictures.Insert(WkPath & "\" & WkPicN & ".jpg")
'   Resize picture
    With WkPic
        .ShapeRange.LockAspectRatio = msoTrue
         W = PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width
         H = PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height
        .Height = 0.95 * H
        .Left = PicRg.Left + (W - .Width) / 2
        .Top = PicRg.Top + (H - .Height) / 2
        
 '       .Width = (PicRg.Cells(1, 1).Width + PicRg.Cells(1, 2).Width + PicRg.Cells(1, 3).Width)
 '       .Height = (PicRg.Cells(1, 1).Height + PicRg.Cells(2, 1).Height + PicRg.Cells(3, 1).Height)
    End With
    Application.ScreenUpdating = True

End Sub

in the sheet's code put

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If (Target.Address <> Range("I13").Address) Then Exit Sub
    Call Treat
End Sub