VBA- Autofit Zoom View to active/visible cells in table?

DarkJester89

Board Regular
Joined
Nov 5, 2017
Messages
109
Office Version
  1. 2016
Platform
  1. Windows
I wasn't able to find any vba zoom except for auto-changing based on resolution, but is it possible to autofit custom zoom level based on most furthest out column that has text?

Code:
Private Sub Workbook_Open()
    ActiveWindow.Zoom = 100  'also you can change to other size
End Sub

Bonus Code: To reset the scroll bar to far left, so it's looking at Column A/Row1, this code works :) I have it on a "reset" userbutton.

VBA Code:
'Scroll to a specific row and column
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
VBA Code:
Function FindFurthestColumn(S As Worksheet) As Integer
    
    Dim CellsWithContent As Long
    CellsWithContent = WorksheetFunction.CountA(S.Cells)
    
    If CellsWithContent = 0 Then
        FindFurthestColumn = 1
        Exit Function
    End If
    
    Dim CellsCount As Long
    Dim j As Integer
    Do
        j = j + 1
        CellsCount = CellsCount + WorksheetFunction.CountA(S.Columns(j))
    Loop Until CellsCount = CellsWithContent
    
    FindFurthestColumn = j
End Function
Code:
Function CellIsVisible(cell As Range) As Boolean
    CellIsVisible = Not Intersect(ActiveWindow.VisibleRange, cell) Is Nothing
End Function
Code:
Sub ZoomVisibleCells()
    
    Application.ScreenUpdating = False
    
    Dim LastColumn As Integer
    LastColumn = FindFurthestColumn(ActiveSheet)
    
    Dim Zoom As Integer
    For Zoom = 400 To 10 Step -1
        ActiveWindow.ScrollRow = 1
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.Zoom = Zoom
        If CellIsVisible(ActiveSheet.Cells(1, LastColumn + 1)) Then
            Exit For
        End If
    Next Zoom
    
    Application.ScreenUpdating = True
End Sub
 

Attachments

  • zoom.png
    zoom.png
    41.5 KB · Views: 4
Upvote 0
Assuming that it is a table range that you are zooming to fit:

VBA Code:
Sub ZoomToTable()
Activesheet.Listobjects(1).Range.Select
ActiveWindow.Zoom = True
End Sub

Is that what you were after, or am I missing something?
 
Upvote 0
VBA Code:
Function FindFurthestColumn(S As Worksheet) As Integer
    
    Dim CellsWithContent As Long
    CellsWithContent = WorksheetFunction.CountA(S.Cells)
    
    If CellsWithContent = 0 Then
        FindFurthestColumn = 1
        Exit Function
    End If
    
    Dim CellsCount As Long
    Dim j As Integer
    Do
        j = j + 1
        CellsCount = CellsCount + WorksheetFunction.CountA(S.Columns(j))
    Loop Until CellsCount = CellsWithContent
    
    FindFurthestColumn = j
End Function

Function CellIsVisible(cell As Range) As Boolean
    CellIsVisible = Not Intersect(ActiveWindow.VisibleRange, cell) Is Nothing
End Function

Sub ZoomVisibleCells()
    
    Application.ScreenUpdating = False
    
    Dim LastColumn As Integer
    LastColumn = FindFurthestColumn(ActiveSheet)
    
    Dim SplitCell As Range
    If ActiveWindow.Split = True Then
        Set SplitCell = Cells(ActiveWindow.SplitRow + 1, ActiveWindow.SplitColumn + 1)
        ActiveWindow.FreezePanes = False
    End If
    
    Dim Zoom As Integer
    For Zoom = 400 To 10 Step -1
        ActiveWindow.ScrollRow = 1
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.Zoom = Zoom
        If CellIsVisible(ActiveSheet.Cells(1, LastColumn + 1)) Then
            Exit For
        End If
    Next Zoom
    
    If Not SplitCell Is Nothing Then
        SplitCell.Activate
        ActiveWindow.FreezePanes = True
    End If
    
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,544
Messages
6,114,249
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top