Maintain aspect ratio of window Excel VBA with auto resize (zoom)

Have you ever created a cool application or spreadsheet in Excel?  Some of you may have even taken steps to remove the ribbon and status bar so that the user must use the program as you intended it.

The problem with this, is you might end up with the user resizing the window and seeing cells outside of the bounds that you want them to view.

Another problem you might run into, is you have users who wish the window to be larger or smaller on their screen.  To fix this issue, add this VBA code to your Excel program. Don't forget to also add a reference to this code in the Workbook_WindowResize function.

Note: This code works best in office 2016. Earlier versions of office don't trigger the Workbook_WindowResize event when the application window changes size. To fix this, you can run this subroutine recursively with an application.ontime, or you can add it to another event such as Workbook_SheetSelectionChange.

 Public Sub resizeWindow()    
   'Checks the size of the application and scales the window or application accordingly.    
     
   On Error Resume Next    
     
   Dim newSize, naturalHeight, naturalWidth, aspectRatio, aspectTolerance    
   Dim currentRatio    
     
   'Set options. These items should be changed to fit your application    
   naturalHeight = 661   'Height of window when at zoom 100%    
   naturalWidth = 875   'Width of window when at zoom 100%    
   aspectTolerance = 0.15  'Allow some horizontal resizing room    
     
   'Make sure that this workbook is the active    
   'workbook and isn't minimized. Otherwise, skip the scaling    
   If Application.WindowState = xlMinimized Then Exit Sub    
   If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Sub    
   Application.ScreenUpdating = False    
     
   'Calculate aspect ratios    
   aspectRatio = naturalWidth / naturalHeight    
   currentRatio = Application.Width / Application.Height    
     
   If Application.Version > 14 Then    
   'if office 2016 or later    
    newSize = (Application.Windows.Item(ThisWorkbook.Name).Height / naturalHeight) * 100    
      
       'max 100% zoom, min 50% zoom    
    If newSize > 100 Then newSize = 100    
    If newSize < 50 Then newSize = 50    
    ActiveWindow.Zoom = newSize    
      
       'maintain minimum and maximum window size    
    If Application.Windows.Item(ThisWorkbook.Name).Height < (naturalHeight * 0.5) Then    
    Application.Windows.Item(ThisWorkbook.Name).Height = (naturalHeight * 0.5)    
    ElseIf Application.Windows.Item(ThisWorkbook.Name).Height > (naturalHeight) Then    
    Application.Windows.Item(ThisWorkbook.Name).Height = (naturalHeight)    
    End If    
   Else    
   'office 2013 and earlier    
    'if window size = application size    
    If (Application.Windows.Item(ThisWorkbook.Name).Height * 0.95) < Application.Height And (Application.Windows.Item(ThisWorkbook.Name).Height * 1.05) > Application.Height Then    
      
       'yes: adjust application size    
    ActiveWindow.Zoom = (Application.Height / naturalHeight) * 100    
    Else    
    'no: adjust window size    
    ActiveWindow.Zoom = (Application.Windows.Item(ThisWorkbook.Name).Height / naturalHeight) * 100    
    End If    
   End If    
     
   'scroll to top left    
   ActiveWindow.ScrollColumn = 1    
   ActiveWindow.ScrollRow = 1    
     
   'maintain aspect ratio    
   If currentRatio < (aspectRatio - aspectTolerance) Then Application.Width = Application.Height * aspectRatio    
   If currentRatio > (aspectRatio + aspectTolerance) Then Application.Width = Application.Height * aspectRatio    
     
   'enable screenupdating and events    
   Application.ScreenUpdating = True    
   Application.enableEvents = True    
  End Sub