De: Ole P. Erlandsen <ope@st.telia.no>
Objet: Re: Printing non-contiguous ranges on the same page
Date : samedi 2 octobre 1999 07:26

Would this slightly modified code example help to solve your problem?
The changes are marked with '***.

Sub DoPrintSelectedCells() '*** Added this sub to run the main sub
    PrintSelectedCells True ' True=Horizontal, False=Vertical
End Sub

Sub PrintSelectedCells(Horizontal As Boolean) '*** added the boolean
argument
Dim aCount As Integer, cCount As Integer, rCount As Integer, i As Integer, j
As Long, aRange As String, rHeight() As Single, cWidth() As Single, 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 ActiveCell ' pastes values and formats '*** changed to
ActiveCell
                .PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
                .PasteSpecial Paste:=xlFormats, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
            End With
            Application.CutCopyMode = False
            '*** activate the next target cell
            If Horizontal Then
                ActiveCell.Offset(0, Range(aRange).Columns.Count).Select
            Else
                ActiveCell.Offset(Range(aRange).Rows.Count, 0).Select
            End If
            '*** No more editing...
        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


HTH
--
Ole P. Erlandsen
ope@st.telia.no
http://home.telia.no/exceltips/


Tommy Flynn <tommy.flynn@cplc.com> wrote in message
news:7t2d57$4bn$1@gaddy.interpath.net...
> Hi,
>
> Thanks.  This works as far as selecting the cells to print and placing
them
> in a new workbook.
[snip]
> I messed with your macro and tried to get it to place the copied areas
> adjacent to each other, but couldn't get it to work.


 