copy print areas from multiple sheets to one sheet

[jimrward]

since excel is awkward at printing and insists on a separate sheet for each print

does anyone have some ready made code to loop thru all worksheets in a workbook and copy the print area from each, with the following rules

will not always be the same size area
may or may not exist

if it exists then paste the area to a single new worksheet so that it can be printed, with 2 lines between each area for clarity, I can add pagebreaks manually

I found the following and tried to modify for print areas but it keeps blowing up excel with out of memory and trying to report back to the microsoft mothership, and on the extra sheet it seems to work find for the first area and then for the second it gets it wrong and pastes the wrong bit

     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
            p = wsh.PageSetup.PrintArea
            If p <> "" Then
                i = i + 1
                If i > 1 Then   ' resize array
                    ReDim Preserve rngArr(1 To i)
                End If

                Set rngArr(i) = wsh.Range(p)
            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

 

[Peter_SSs]

I haven't gone into as much detail as your code, but does this solve the basic problem? It skips any sheets that do not have a specific Print Area set. Is that what you wanted or do you want the whole used range on the temp sheet for any sheet that doesn't have a Print Area specifically set?

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Copy_Print_Areas()<br>    <SPAN style="color:#00007F">Dim</SPAN> wshTemp <SPAN style="color:#00007F">As</SPAN> Worksheet, wsh <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <SPAN style="color:#00007F">Dim</SPAN> lDestRw <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> wshTemp = Sheets.Add(After:=Worksheets(Worksheets.Count))<br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> wsh <SPAN style="color:#00007F">In</SPAN> ActiveWorkbook.Worksheets<br>        <SPAN style="color:#00007F">With</SPAN> wsh<br>            <SPAN style="color:#00007F">If</SPAN> .Name <> wshTemp.Name <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">If</SPAN> .PageSetup.PrintArea <> "" <SPAN style="color:#00007F">Then</SPAN><br>                    <SPAN style="color:#00007F">With</SPAN> wshTemp.UsedRange<br>                        lDestRw = .Row + .Rows.Count + 2<br>                    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>                    .Range(.PageSetup.PrintArea).Copy<br>                    wshTemp.Cells(lDestRw, 1).PasteSpecial _<br>                        Paste:=xlValues<br>                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> wsh<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[jimrward]

peter, almost there and much tidier, what I need to do is bring the formatting across as well, I am using Excel 2010, just trying to find the correct pastespecial option

 

[jimrward]

ok got there in the end, i changed your pastespecial to the following

Sub Copy_Print_Areas()
    Dim wshTemp As Worksheet, wsh As Worksheet
    Dim lDestRw As Long
    
    Application.ScreenUpdating = False
    Set wshTemp = Sheets.Add(After:=Worksheets(Worksheets.Count))
    For Each wsh In ActiveWorkbook.Worksheets
        With wsh
            If .Name <> wshTemp.Name And .Name <> "Setup" Then
                If .ProtectContents = True Then
                    .Unprotect
                End If
                If .PageSetup.PrintArea <> "" Then
                    With wshTemp.UsedRange
                        lDestRw = .Row + .Rows.Count + 2
                    End With
                    .Range(.PageSetup.PrintArea).Copy
                    wshTemp.Cells(lDestRw, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                    wshTemp.Cells(lDestRw, 1).PasteSpecial Paste:=xlPasteColumnWidths
                    wshTemp.Cells(lDestRw, 1).PasteSpecial Paste:=xlPasteFormats

                End If
            End If
        End With
    Next wsh
    Application.ScreenUpdating = True
End Sub