Hello,
I found a VBA code that prints multiple worksheets to one page. It works well but it also prints hidden pages which I cant use and it prints the whole worksheet. I need it to print just the areas that contain data. Can anyone help with this. Thank you in advance
Sub PrintOnePage()
Dim wshTemp As Worksheet, wsh As Worksheet
Dim rngArr() As Range, c As Range
Dim i As Integer
Dim j As Integer
ReDim rngArr(1 To 1)
For Each wsh In ActiveWorkbook.Worksheets
i = i + 1
If i > 1 Then ' resize array
ReDim Preserve rngArr(1 To i)
End If
On Error Resume Next
Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell)
If Err = 0 Then
On Error GoTo 0
'Prevent empty rows
Do While Application.CountA(c.EntireRow) = 0 _
And c.EntireRow.Row > 1
Set c = c.Offset(-1, 0)
Loop
Set rngArr(i) = wsh.Range(wsh.Range("A1"), c)
End If
Next wsh
'Add temp.Worksheet
Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))
On Error Resume Next
With wshTemp
For i = 1 To UBound(rngArr)
If i = 1 Then
Set c = .Range("A1")
Else
Set c = _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row
End If
'Copy-paste range (prevent empty range)
If Application.CountA(rngArr(i)) > 0 Then
rngArr(i).Copy c
End If
Next i
End With
On Error GoTo 0
Application.CutCopyMode = False ' prevent marquies
With ActiveSheet.PageSetup ' Fit to 1 page
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
'Preview New Sheet
ActiveWindow.SelectedSheets.PrintPreview
'Print Desired Number of Copies
i = InputBox("Print how many copies?", "ExcelTips", 1)
If IsNumeric(i) Then
If i > 0 Then
ActiveSheet.PrintOut Copies:=i
End If
End If
'Delete temp.Worksheet?
If MsgBox("Delete the temporary worksheet?", _
vbYesNo, "ExcelTips") = vbYes Then
Application.DisplayAlerts = False
wshTemp.Delete
Application.DisplayAlerts = True
End If
End Sub
I found a VBA code that prints multiple worksheets to one page. It works well but it also prints hidden pages which I cant use and it prints the whole worksheet. I need it to print just the areas that contain data. Can anyone help with this. Thank you in advance
Sub PrintOnePage()
Dim wshTemp As Worksheet, wsh As Worksheet
Dim rngArr() As Range, c As Range
Dim i As Integer
Dim j As Integer
ReDim rngArr(1 To 1)
For Each wsh In ActiveWorkbook.Worksheets
i = i + 1
If i > 1 Then ' resize array
ReDim Preserve rngArr(1 To i)
End If
On Error Resume Next
Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell)
If Err = 0 Then
On Error GoTo 0
'Prevent empty rows
Do While Application.CountA(c.EntireRow) = 0 _
And c.EntireRow.Row > 1
Set c = c.Offset(-1, 0)
Loop
Set rngArr(i) = wsh.Range(wsh.Range("A1"), c)
End If
Next wsh
'Add temp.Worksheet
Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))
On Error Resume Next
With wshTemp
For i = 1 To UBound(rngArr)
If i = 1 Then
Set c = .Range("A1")
Else
Set c = _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row
End If
'Copy-paste range (prevent empty range)
If Application.CountA(rngArr(i)) > 0 Then
rngArr(i).Copy c
End If
Next i
End With
On Error GoTo 0
Application.CutCopyMode = False ' prevent marquies
With ActiveSheet.PageSetup ' Fit to 1 page
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
'Preview New Sheet
ActiveWindow.SelectedSheets.PrintPreview
'Print Desired Number of Copies
i = InputBox("Print how many copies?", "ExcelTips", 1)
If IsNumeric(i) Then
If i > 0 Then
ActiveSheet.PrintOut Copies:=i
End If
End If
'Delete temp.Worksheet?
If MsgBox("Delete the temporary worksheet?", _
vbYesNo, "ExcelTips") = vbYes Then
Application.DisplayAlerts = False
wshTemp.Delete
Application.DisplayAlerts = True
End If
End Sub