...

MS Excel VBA

Zoom The Selected Range In Excel Sheet With VBA

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  
Otherwise font size same

Leave a Comment

Your email address will not be published. Required fields are marked *


Scroll to Top