Auto Resize to fit different monitor sizes

Alan64

New Member
Joined
May 16, 2019
Messages
13
Hi - Could someone please give me bit of assistance, I am trying to get an excel document to auto resize to different monitor/screen sizes so bosses do not have to scroll around document. I have tried the code below but does not work (also not sure if putting in the right place, fairly new to this).I open the developer, this workbook and set to workbook open then paste code in. I am currently using window 7 and most of company has changed to windows 10(I will be shortly). Thanks for any help
<style>body,.top-bar{margin-top:1.9em}</style>
Sub Zoomitgood()
'this macro will loop through all thesheets and zoom to fit the contents by
'measuring the width andheight of each sheet. It will then zoom to 90% of
'the "zoom tofit" setting.

Dim WS_Count As Integer
Dim iAs Integer
Dim jAs Integer
Dim kAs Integer
Dimmaxwidth As Integer
Dimwidth As Integer
DimHeight As Integer
DimMaxHeight As Integer
Dimzoom As Integer

'First Loop: Loop through each sheet,select each sheet so that each width
'and height can bemeasured. The width and height are measured in number of
'cells.

WS_Count =ActiveWorkbook.Worksheets.Count
For i = 1To WS_Count
Worksheets(i).Activate
maxwidth =
0
MaxHeight =
0

'Second loop: measure the width ofeach sheet by running line by line and
'finding the rightmostcell. The maximum value of the rightmost cell will be
'set to the maxwidthvariable

For j = 1To 100
width = Cells(j,
100).End(xlToLeft).Column
If width >= maxwidth Then

maxwidth = width
End If
Next
'Third loop: measure the height ofeach sheet by running line by line and
'finding the rightmostcell. The maximum value of the lowest cell will be
'set to the maxheightvariable.

For k = 1To 100
Height = Cells(
100, k).End(xlUp).Row
If Height >= MaxHeight Then

MaxHeight = Height
End If
Next
'Finally, back to loop 1, select therange for zooming. Then set the zoom to
'90% of full zoom.

Range(Cells(1, 1), Cells(MaxHeight, maxwidth)).Select
ActiveWindow.zoom =
True
zoom = ActiveWindow.zoom
ActiveWindow.zoom = zoom *
0.9
Cells(
1000, 1000).Select
Application.CutCopyMode =
False
ActiveWindow.ScrollRow =
1
ActiveWindow.ScrollColumn =
1

Next
MsgBox "You have been zoomed"
Application.ScreenUpdating = True
Application.DisplayAlerts =
True

End Sub
 
Last edited:

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Wow, that's a lot of code.

How about this:

Code:
Sub Rezoom()
  Dim wsActive As Worksheet
  Set wsActive = ActiveSheet
  Dim ws As Worksheet
  For Each ws In ActiveWorkbook.Worksheets
    ws.Activate
    ws.UsedRange.Select
    ActiveWindow.Zoom = True
    ws.Range("A1").Select
  Next
  wsActive.Activate
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,702
Messages
6,173,932
Members
452,539
Latest member
delvey

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