Sub FitDataToWindow()
Dim ratio As Double
Dim rw As Long, col As Long
Dim cTL As Range, cBR As Range, rData As Range
Dim wn As Window
LastDcell ActiveSheet, rw, col, False
Set cTL = Cells(rw, col)
LastDcell ActiveSheet, rw, col, True
Set cBR = Cells(rw, col)
Set rData = Range(cTL, cBR)
Set cTL = rData(1)
Set cBR = rData(rData.Cells.Count)
Application.Goto cTL, True
Set wn = ActiveWindow
wn.Zoom = 100
With wn.VisibleRange
ratio = .Resize(, .Columns.Count - 1).Width / rData.Width
If (ratio > .Resize(.Rows.Count - 1).Height / rData.Height) Then
ratio = .Resize(.Rows.Count - 1).Height / rData.Height
' will zoom to height
End If
End With
' zoom can be betweeen 10-400
If ratio > 4 Then ratio = 4
If ratio < 0.1 Then ratio = 0.1 ' can't show all data!
wn.Zoom = Int(ratio * 100)
If ratio > 0.1 Then
' might need to reduce zoom slightly if last cell not in window
If Intersect(wn.VisibleRange, cBR) Is Nothing Then
wn.Zoom = wn.Zoom - 1
End If
End If
End Sub
Function LastDcell(ws As Worksheet, dR As Long, dc As Long, _
bLastCell As Boolean) As Boolean
Dim x
Dim SrchDir As XlSearchDirection
If bLastCell Then
SrchDir = xlPrevious
Else
SrchDir = xlNext
End If
On Error GoTo errH
With ws.Cells
dc = .Find("*", .Range("A1"), xlFormulas, xlPart, _
xlByColumns, SrchDir, 0).Column
dR = .Find("*", .Range("A1"), xlFormulas, xlPart, _
xlByColumns, SrchDir, 0).Row
x = .Find("") 'reset Find
End With
Exit Function
errH:
' typically empty sheet
dR = 1
dc = 1
End Function
Only light tested ...
Regards,
Peter T
