adjust zoom according to sheet
 

i am newbie to vba programming ... i need to set the zoom according to
the sheets in such a way that content present in the page should
exactly fit in one page ... if i need to provide further details pls
let me know.

adjust zoom according to sheet
 

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

"vicky" wrote in message
...
i am newbie to vba programming ... i need to set the zoom according to
the sheets in such a way that content present in the page should
exactly fit in one page ... if i need to provide further details pls
let me know.

adjust zoom according to sheet
 

TYPO !

in LastDcell() change
dR = .Find("*", .Range("A1"), xlFormulas, xlPart, _
xlByColumns, SrchDir, 0).Row
to

dR = .Find("*", .Range("A1"), xlFormulas, xlPart, _
xlByRows, SrchDir, 0).Row

With that corrected can get rid of
Set cTL = rData(1)
Set cBR = rData(rData.Cells.Count)

Regards,
Peter T

"Peter T" <peter_t@discussions wrote in message
...
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

"vicky" wrote in message
...
i am newbie to vba programming ... i need to set the zoom according to
the sheets in such a way that content present in the page should
exactly fit in one page ... if i need to provide further details pls
let me know.

adjust zoom according to sheet
 

On Nov 3, 5:36*pm, "Peter T" <peter_t@discussions wrote:
TYPO !

in LastDcell() change
* * * * dR = .Find("*", .Range("A1"), xlFormulas, xlPart, _
* * * * * * * * * * * * * * * * * * xlByColumns, SrchDir, 0).Row
to

* * * * dR = .Find("*", .Range("A1"), xlFormulas, xlPart, _
* * * * * * * * * * * * * * * * * * xlByRows, SrchDir, 0).Row

With that corrected can get rid of
* * Set cTL = rData(1)
* * Set cBR = rData(rData.Cells.Count)

Regards,
Peter T

"Peter T" <peter_t@discussions wrote in message

...



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

"vicky" wrote in message
....
i am newbie to vba programming ... i need to set the zoom according to
the sheets in such a way that content present in the page should
exactly fit in one page ... if i need to provide further details pls
let me know.- Hide quoted text -

- Show quoted text -

thanks a lot peter .