Skip to content 
zoom inside the shape code.
'For more : https://msexcelvba.com
'Zoom In Make A Shapes
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range, rng2 As Range, Zoom As Single
Set rng = Selection
Zoom = 1.6 'Zoom rate
For Each rng2 In Selection 'If there are blank rng2s in selection, shapes are deleted and ended method
If rng2.Value = Empty Then
Call delete_picture
GoTo here:
Exit Sub
End If
Next
Call delete_picture 'Remove any existing zoom pictures
Application.ScreenUpdating = False
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture 'Create zoom picture
ActiveSheet.Pictures.Paste.Select
With Selection
.Name = "zoom"
With .ShapeRange
.ScaleWidth Zoom, msoFalse, msoScaleFromTopLeft
.ScaleHeight Zoom, msoFalse, msoScaleFromTopLeft
With .Fill
.ForeColor.SchemeColor = 44
.Visible = msoTrue
.Solid
.Transparency = 0
End With
End With
End With
here:
rng.Select
Application.ScreenUpdating = True
Set rng = Nothing
End Sub
Sub delete_picture() 'Remove any existing zoom pictures
Dim O As Object
For Each O In ActiveSheet.Pictures
If O.Name = "zoom" Then
O.Delete
End If
Next
End Sub
zoom desired the fonts size.
'For more : https://msexcelvba.com
Private STR As String, STR1 As String, STR2 As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Range(STR1).Font.Size = STR
Range(STR1).Width = STR2
If Target <> Empty Then
STR = Target.Font.Size
STR1 = Target.Address
STR2 = Target.Width
'MsgBox STR2
Target.Font.Size = STR * 1.7 'You can type the desired font size here
Target.EntireColumn.AutoFit
Else
Target.Font.Size = STR
Target.Width = STR2
End If
End Sub
Code Explanation zoom shape.
Dim rng As Range, rng2 As Range, Zoom As Single
Set rng = Selection Declare variables and set the range in mouse selection
Zoom = 1.6 set the Zoom rate
For Each rng2 In Selection
If rng2.Value = Empty Then
Call delete_picture
GoTo here:
Exit Sub
End If
Next If there are blank rng2s in selection, shapes are deleted and ended method
Call delete_picture Delete any existing zoom pictures
Application.ScreenUpdating = False Screen-updating object to false then it will speed up the macro
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ActiveSheet.Pictures.Paste.Select
With Selection
.Name = "zoom"
With .ShapeRange
.ScaleWidth Zoom, msoFalse, msoScaleFromTopLeft
.ScaleHeight Zoom, msoFalse, msoScaleFromTopLeft
With .Fill
.ForeColor.SchemeColor = 44
.Visible = msoTrue
.Solid
.Transparency = 0
End With
End With
End With
here:
rng.Select
Application.ScreenUpdating = True
Set rng = Nothing Create a zoom picture and screen updating turn on
Sub delete_picture()
Dim O As Object
For Each O In ActiveSheet.Pictures
If O.Name = "zoom" Then
O.Delete
End If
Next
End Sub Delete any existing zoom pictures subject
zoom inside the Fonts Size code.
'For more : https://msexcelvba.com
Private STR As String, STR1 As String, STR2 As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Range(STR1).Font.Size = STR
Range(STR1).Width = STR2
If Target <> Empty Then
STR = Target.Font.Size
STR1 = Target.Address
STR2 = Target.Width
'MsgBox STR2
Target.Font.Size = STR * 1.7 'You can type the desired font size here
Target.EntireColumn.AutoFit
Else
Target.Font.Size = STR
Target.Width = STR2
End If
End Sub
Code Explanation Font Size.
Private STR As String, STR1 As String, STR2 As String Declare variables
On Error Resume Next if any error skip it go to next line
Range(STR1).Font.Size = STR
Range(STR1).Width = STR2 Set range font size with variables
If Target <> Empty Then if condition if current selection empty then code run
STR = Target.Font.Size
STR1 = Target.Address
STR2 = Target.Width Set variables
Target.Font.Size = STR * 1.7 (Fonts size );You can type the desired font size here
Target.EntireColumn.AutoFit Selection Column Automatically fit as per our font size
Else
Target.Font.Size = STR
Target.Width = STR2
End If 
