The_Macrotect
Board Regular
- Joined
- Dec 11, 2017
- Messages
- 111
Hi all,
I am exporting data to Excel, and I'd like a macro that will resize it to fit on either letter size paper or legal. I've accomplished this by finding out how many rows of data will fit on letter. If the number of rows is greater than that, it will print on legal.
What I'd like for it to do next is fill the page. I tried accomplishing this with a loop that increases the zoom in page setup until the number of pages is 2 and then decreases it again so it fits on 1, but it just keeps zooming in until it can't anymore and I get an error. Here is my code:
**Edit: I'm using Office 2016**
I appreciate any thoughts or feedback on what's causing this, or a better way to do it![Smile :) :)](data:image/gif;base64,R0lGODlhAQABAIAAAAAAAP///yH5BAEAAAAALAAAAAABAAEAAAIBRAA7)
All the best,
Matt
I am exporting data to Excel, and I'd like a macro that will resize it to fit on either letter size paper or legal. I've accomplished this by finding out how many rows of data will fit on letter. If the number of rows is greater than that, it will print on legal.
What I'd like for it to do next is fill the page. I tried accomplishing this with a loop that increases the zoom in page setup until the number of pages is 2 and then decreases it again so it fits on 1, but it just keeps zooming in until it can't anymore and I get an error. Here is my code:
**Edit: I'm using Office 2016**
VBA Code:
Sub Format_Deco()
Dim x As Integer, lrow As Integer
x = 1
Rows(6).Delete
Rows(5).Delete
Rows(3).Delete
Rows(1).Delete
lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
Do Until Cells(x, 1).Value = "Total:"
x = x + 1
If Cells(x, 1).Value = "" Then
Rows(x).Delete
lrow = lrow - 1
End If
If Cells(x, 1).Value = "Subsubtotal:" Then
Range("A" & x & ":D" & x).ClearContents
End If
If Cells(x, 1).Value = "Subtotal:" Then
Rows(x).Delete
lrow = lrow - 1
End If
Loop
Rows(x).Delete
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.Orientation = xlPortrait
.Zoom = 140
End With
If lrow < 36 Then
ActiveSheet.PageSetup.PaperSize = xlPaperLetter
MsgBox ("Will print on LETTER size paper")
If ActiveSheet.PageSetup.Pages.Count > 1 Then
Do Until ActiveSheet.PageSetup.Pages.Count = 1
ActiveSheet.PageSetup.Zoom = ActiveSheet.PageSetup.Zoom - 1
Loop
End If
Do Until ActiveSheet.PageSetup.Pages.Count = 2
ActiveSheet.PageSetup.Zoom = ActiveSheet.PageSetup.Zoom + 1
Loop
ActiveSheet.PageSetup.Zoom = ActiveSheet.PageSetup.Zoom - 1
Else: ActiveSheet.PageSetup.PaperSize = xlPaperLegal
MsgBox ("Will print on LEGAL size paper")
End If
End Sub
I appreciate any thoughts or feedback on what's causing this, or a better way to do it
All the best,
Matt