Print multiple selections on one sheet
2000-02-04 Printing 0 227
If you select multiple cell ranges on one sheet and tries to print out selected cells you will get one sheet for each of the selected areas. The following example macro will print all the selected areas on one sheet, except if the areas are too large to fit in one sheet.
Sub PrintSelectedCells() ' prints selected cells, use from a toolbar button or a menu Dim aCount As Integer, cCount As Integer, rCount As Integer Dim i As Integer, j As Long, aRange As String Dim rHeight() As Single, cWidth() As Single Dim AWB As Workbook, NWB As Workbook If UCase(TypeName(ActiveSheet)) <> "WORKSHEET" Then Exit Sub ' useful only in worksheets aCount = Selection.Areas.Count If aCount = 0 Then Exit Sub ' no cells selected cCount = Selection.Areas(1).Cells.Count If aCount > 1 Then ' multiple areas selected Application.ScreenUpdating = False Application.StatusBar = "Printing " & aCount & " selected areas..." Set AWB = ActiveWorkbook rCount = ActiveSheet.Cells.SpecialCells(xlLastCell).Row cCount = ActiveSheet.Cells.SpecialCells(xlLastCell).Column ReDim rHeight(rCount) ReDim cWidth(cCount) For i = 1 To rCount ' find the row height of every row in the selection rHeight(i) = Rows(i).RowHeight Next i For i = 1 To cCount ' find the column width of every column in the selection cWidth(i) = Columns(i).ColumnWidth Next i Set NWB = Workbooks.Add ' create a new workbook For i = 1 To rCount ' set row heights Rows(i).RowHeight = rHeight(i) Next i For i = 1 To cCount ' set column widths Columns(i).ColumnWidth = cWidth(i) Next i For i = 1 To aCount AWB.Activate aRange = Selection.Areas(i).Address ' the range address Range(aRange).Copy ' copying the range NWB.Activate With Range(aRange) ' pastes values and formats .PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False .PasteSpecial Paste:=xlFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End With Application.CutCopyMode = False Next i NWB.PrintOut NWB.Close False ' close the temporary workbook without saving Application.StatusBar = False AWB.Activate Set AWB = Nothing Set NWB = Nothing Else If cCount < 10 Then ' less than 10 cells selected If MsgBox("Are you sure you want to print " & _ cCount & " selected cells ?", _ vbQuestion + vbYesNo, "Print celected cells") = vbNo Then Exit Sub End If Selection.PrintOut End If End Sub