تكبير الخلية كوريجيبيلي

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.5, msoFalse, msoScaleFromTopLeft

            .ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft

            With .Fill

                .ForeColor.SchemeColor = 44

                .Visible = msoTrue

                .Solid

                .Transparency = 0

            End With

        End With

    End With

    xRg.Select

    Application.ScreenUpdating = True

    Set xRg = Nothing

End Sub