Excel Window Autozoom based on cell

[pingme89]

I have an Excel application where I only want a specified range visible. Whenever a user moves Excel to a new window with a different resolution, the zoom factor gets messed up. Also users do not necessarily keep the Excel app in full screen either.

So I have a list of Worksheet Names and Cell Addresses on a worksheet labelled "Settings".

For Example

Sheet1	AJ48
Sheet2	AC59
Sheet3	Y36
Sheet4	AT123

I want to loop through the Sheet names and starting from 200 zoom factor to reduce the zoom factor by 1 until the specified Cell is visible in the Excel window.

The code I have doesn't work.

Sub EnsureCellVisible()
    Dim wsSettings As Worksheet
    Dim ws As Worksheet
    Dim cell As Range
    Dim Marker As Variant
    Dim zoomFactor As Double
    Dim CellRow As Long
    Dim CellMark As String
    
    ' Set the worksheet containing the settings
    Set wsSettings = ThisWorkbook.Sheets("Settings")

    ' Loop through each row in the Settings worksheet starting from row 2
    For Each cell In wsSettings.Range("A2:A" & wsSettings.Cells(wsSettings.Rows.Count, "A").End(xlUp).Row)
        ' Get the worksheet name from column A
        Set ws = ThisWorkbook.Sheets(cell.Value)
        CellRow = cell.Row
        ' Get the cell address from column B
        Marker = ThisWorkbook.Worksheets("Settings").Range("B" & CellRow).Text
        ' Activate the worksheet
        ws.Range("A1").Activate
        
        For i = 200 To 10 Step -1
            ws.Parent.Windows(1).Zoom = i
            If ws.Range(Marker).Visible Then
                Exit For
            End If
        Next i
    Next cell
End Sub

The portion of the code that doesn't seem to work is this: If ws.Range(Marker).Visible Then
I almost feel that the cell is "visible" meaning it the row or column it is in, is visible.
I want to check if it is optically visible in the window.

Any help would be greatly appreciated.

 

[myall_blues]

See if this works for you.

Sub EnsureCellVisible()
    Dim wsSettings As Worksheet
    Dim ws As Worksheet
    Dim cell As Range, Visible As Range
    Dim Marker As Variant
    Dim zoomFactor As Double
    Dim CellRow As Long
    Dim CellMark As String
    
    ' Set the worksheet containing the settings
    Set wsSettings = ThisWorkbook.Sheets("Settings")

    ' Loop through each row in the Settings worksheet starting from row 2
    For Each cell In wsSettings.Range("A2:A" & wsSettings.Cells(wsSettings.Rows.Count, "A").End(xlUp).Row)
        ' Get the worksheet name from column A
        Set ws = ThisWorkbook.Sheets(cell.Value)
        CellRow = cell.Row
        ' Get the cell address from column B
        Marker = wsSettings.Range("B" & CellRow).Text
        ' Activate the worksheet
        ws.Activate
        Set Visible = Range(Marker)
        
        For i = 200 To 10 Step -1
            ws.Parent.Windows(1).Zoom = i
            If CellIsVisible(Visible) Then
                Exit For
            End If
        Next i
    Next cell
End Sub

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

 

[pingme89]

Thanks Murray.
I have modified the code slightly as I also needed Range("A1") to also be visible.

Here is the completed code:

Sub EnsureCellVisible()
    Dim wsSettings As Worksheet
    Dim ws As Worksheet
    Dim cell As Range
    Dim Marker As Variant
    Dim CellRow As Long
    Dim CellMark As String
    Dim Visible As Range
    
    ' Set the worksheet containing the settings
    Set wsSettings = ThisWorkbook.Sheets("Settings")

    ' Loop through each row in the Settings worksheet starting from row 2
    For Each cell In wsSettings.Range("A2:A" & wsSettings.Cells(wsSettings.Rows.Count, "A").End(xlUp).Row)
        ' Get the worksheet name from column A
        Set ws = ThisWorkbook.Sheets(cell.Value)
        CellRow = cell.Row
        ' Get the cell address from column B
        Marker = ThisWorkbook.Worksheets("Settings").Range("B" & CellRow).Text
        ' Activate the worksheet
        ws.Activate
        ws.Range("A1").Select
        Set Visible = Range(Marker)
        
        For i = 200 To 10 Step -1
            ws.Parent.Windows(1).Zoom = i
            If CellIsVisible(Visible) Then
                
                Exit For
            End If
        Next i
    Next cell
End Sub

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

 

[myall_blues]

Glad it worked.