magnify selected cell

[Mohsen_mrd]

Hello Friends,

I found this code while searching on the web which zoom cells when selected.
How to change this code to show the shape in the center of worksheet?

Private Sub worksheet_selectionchange(ByVal Target As Range)
'Updateby Extendoffice
       
    Dim xRg As Range
    Dim xCell As Range
    Dim xShape As Variant
    Set xRg = Target.Areas(1)
    For Each xShape In ActiveSheet.Pictures
        If xShape.Name = "zoom_cells" Then
            xShape.Delete
        End If
    Next
    If Application.WorksheetFunction.CountBlank(xRg) = xRg.Count Then Exit Sub
    Application.ScreenUpdating = False
    xRg.CopyPicture appearance:=xlScreen, Format:=xlPicture
    Application.ActiveSheet.Pictures.Paste.Select
    With Selection
        .Name = "zoom_cells"
        With .ShapeRange
            .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
            .ScaleHeight 2.4, msoFalse, msoScaleFromTopLeft
            With .Fill
                .ForeColor.SchemeColor = 1
                .Visible = msoTrue
                .Solid
                .Transparency = 0
            End With
        End With
    End With
    xRg.Select
    Application.ScreenUpdating = True
    Set xRg = Nothing

End Sub

Any help would be appreciated.

Thanks