daniel_9
01-12-2013, 01:02 PM
I'm writing a macro that basically copies all of the printable areas of one workbook into a new workbook. Each separate print range of the source workbook gets pasted into its own sheet in the new workbook. So if there are four separate print ranges in a sheet, it creates four sheets in the new workbook and pastes the stuff from the print range to the new workbook.
I have it paste the values and all the formatting (but not the formulas because there are a lot of calculations going on behind the scenes and I didn't want to deal with it).
When I select a single sheet, the macro works fine. It creates a new workbook, pastes all my print ranges, sets all the print settings correctly, and prints the document. When I select MULTIPLE sheets, however, the macro fails at the first PasteSpecial, returning an error 1004 and saying that it can't paste because the destination cells aren't the correct size and shape as the source cells.
I'm not sure what the problem is. It doesn't SEEM to be copying multiple sheets (when I run the copy command), and I'm selecting the same range in the destination document as the source document, so it should be the same size and shape. There are no merged cells (and I've actually tested on a single sheet that DOES have merged cells and it worked fine!)
So I'm not quite sure where the error is. Again, the error ONLY occurs when I select multiple sheets. This is problem because if I want to print several sheets from a project this way, I would have to do each sheet separately.
The following is my code. The function "copy_print_settings" that you see basically just copies each item from the source sheet PageSetup to the destination, and there are no errors being thrown there so I didn't include it.
TL;DR: Code below works when there's a single sheet selected, but not when multiple sheets are selected from the source workbook
Option Explicit
Sub print_fitted()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim selected_sheet_range As Sheets
Dim selected_sheet As Worksheet
Dim ss_print_area() As String
Dim p_area As Variant
Set selected_sheet_range = ActiveWindow.SelectedSheets
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
Dim rowcount As Integer
For Each selected_sheet In selected_sheet_range
ss_print_area() = Split(selected_sheet.PageSetup.PrintArea, ",")
For Each p_area In ss_print_area()
NewBook.Sheets.Add after:=NewBook.Worksheets(NewBook.Worksheets.Count)
selected_sheet.Range(p_area).Copy
'Code fails at the FOLLOWING LINE
'but ONLY WHEN THERE ARE MULTIPLE SHEETS selected from the source workbook!
NewBook.Sheets(NewBook.Worksheets.Count).Range(p_area).PasteSpecial Paste:=xlPasteColumnWidths
NewBook.Sheets(NewBook.Worksheets.Count).Range(p_area).PasteSpecial Paste:=xlPasteValues
NewBook.Sheets(NewBook.Worksheets.Count).Range(p_area).PasteSpecial Paste:=xlPasteFormats
NewBook.Sheets(NewBook.Worksheets.Count).PageSetup.PrintArea = p_area
copy_print_settings NewBook, selected_sheet
For rowcount = 1 To selected_sheet.Range(p_area).Rows.Count
NewBook.Sheets(NewBook.Worksheets.Count).Range(p_area).Rows(rowcount).RowHe ight _
= selected_sheet.Range(p_area).Rows(rowcount).RowHeight
Next rowcount
Next p_area
Next selected_sheet
NewBook.Worksheets(3).Delete
NewBook.Worksheets(2).Delete
NewBook.Worksheets(1).Delete
NewBook.Worksheets.PrintOut ActivePrinter:="Adobe PDF"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have it paste the values and all the formatting (but not the formulas because there are a lot of calculations going on behind the scenes and I didn't want to deal with it).
When I select a single sheet, the macro works fine. It creates a new workbook, pastes all my print ranges, sets all the print settings correctly, and prints the document. When I select MULTIPLE sheets, however, the macro fails at the first PasteSpecial, returning an error 1004 and saying that it can't paste because the destination cells aren't the correct size and shape as the source cells.
I'm not sure what the problem is. It doesn't SEEM to be copying multiple sheets (when I run the copy command), and I'm selecting the same range in the destination document as the source document, so it should be the same size and shape. There are no merged cells (and I've actually tested on a single sheet that DOES have merged cells and it worked fine!)
So I'm not quite sure where the error is. Again, the error ONLY occurs when I select multiple sheets. This is problem because if I want to print several sheets from a project this way, I would have to do each sheet separately.
The following is my code. The function "copy_print_settings" that you see basically just copies each item from the source sheet PageSetup to the destination, and there are no errors being thrown there so I didn't include it.
TL;DR: Code below works when there's a single sheet selected, but not when multiple sheets are selected from the source workbook
Option Explicit
Sub print_fitted()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim selected_sheet_range As Sheets
Dim selected_sheet As Worksheet
Dim ss_print_area() As String
Dim p_area As Variant
Set selected_sheet_range = ActiveWindow.SelectedSheets
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
Dim rowcount As Integer
For Each selected_sheet In selected_sheet_range
ss_print_area() = Split(selected_sheet.PageSetup.PrintArea, ",")
For Each p_area In ss_print_area()
NewBook.Sheets.Add after:=NewBook.Worksheets(NewBook.Worksheets.Count)
selected_sheet.Range(p_area).Copy
'Code fails at the FOLLOWING LINE
'but ONLY WHEN THERE ARE MULTIPLE SHEETS selected from the source workbook!
NewBook.Sheets(NewBook.Worksheets.Count).Range(p_area).PasteSpecial Paste:=xlPasteColumnWidths
NewBook.Sheets(NewBook.Worksheets.Count).Range(p_area).PasteSpecial Paste:=xlPasteValues
NewBook.Sheets(NewBook.Worksheets.Count).Range(p_area).PasteSpecial Paste:=xlPasteFormats
NewBook.Sheets(NewBook.Worksheets.Count).PageSetup.PrintArea = p_area
copy_print_settings NewBook, selected_sheet
For rowcount = 1 To selected_sheet.Range(p_area).Rows.Count
NewBook.Sheets(NewBook.Worksheets.Count).Range(p_area).Rows(rowcount).RowHe ight _
= selected_sheet.Range(p_area).Rows(rowcount).RowHeight
Next rowcount
Next p_area
Next selected_sheet
NewBook.Worksheets(3).Delete
NewBook.Worksheets(2).Delete
NewBook.Worksheets(1).Delete
NewBook.Worksheets.PrintOut ActivePrinter:="Adobe PDF"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub