Solved: taking a portraite page to less landscape

[wibbers2000]

hello

If there a way to take the Information on a portrait page and make to go landscape.

i.e I have a sheet with 1024 rows on, but only 2 columns. If I print this I either get 32 pages of landscape or 28 pages or portrait.

What I would like is the the page to take the anything after the first page and cut and paste it into the 3/4 column and then at the bottom of that to do the same into the 5/6 column etc etc. Therefore maximising the page usage and stop me from printing way to many pages.

all assistance is appreciated.

Regards
Wibbers

[matthewspatrick]

OK, this assumes you want 8 columns of output. I did a sort of brute-force approach; a more elegant method would be to do the "four blocks" in a For...Next loop.

[VBA]
Sub SpecialPrint()

Dim NumRows As Long
Dim RowStart As Long, RowEnd As Long

Dim wb As Workbook
Dim Source As Worksheet

Set Source = ThisWorkbook.Worksheets("Sheet1")
NumRows = Source.Cells(65536, 1).End(xlUp).Row - 1

Set wb = Workbooks.Add
Range("a1:b1").Value = Source.Range("A1:b1").Value
Range("c1:d1").Value = Source.Range("A1:b1").Value
Range("e1:f1").Value = Source.Range("A1:b1").Value
Range("g1:h1").Value = Source.Range("A1:b1").Value

' do first block
RowStart = 2
RowEnd = 1 + Int(NumRows / 4) + IIf(NumRows Mod 4 > 0, 1, 0)
Source.Range(Source.Cells(RowStart, 1), Source.Cells(RowEnd, 2)).Copy
Cells(2, 1).PasteSpecial Paste:=xlPasteValues
Cells(2, 1).PasteSpecial Paste:=xlPasteFormats

' do 2nd block
RowStart = RowEnd + 1
RowEnd = RowEnd + Int(NumRows / 4) + IIf(NumRows Mod 4 > 1, 1, 0)
Source.Range(Source.Cells(RowStart, 1), Source.Cells(RowEnd, 2)).Copy
Cells(2, 3).PasteSpecial Paste:=xlPasteValues
Cells(2, 3).PasteSpecial Paste:=xlPasteFormats

' do 3rd block
RowStart = RowEnd + 1
RowEnd = RowEnd + Int(NumRows / 4) + IIf(NumRows Mod 4 > 2, 1, 0)
Source.Range(Source.Cells(RowStart, 1), Source.Cells(RowEnd, 2)).Copy
Cells(2, 5).PasteSpecial Paste:=xlPasteValues
Cells(2, 5).PasteSpecial Paste:=xlPasteFormats

' do 4th block
RowStart = RowEnd + 1
RowEnd = RowEnd + Int(NumRows / 4)
Source.Range(Source.Cells(RowStart, 1), Source.Cells(RowEnd, 2)).Copy
Cells(2, 7).PasteSpecial Paste:=xlPasteValues
Cells(2, 7).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False

Columns.ColumnWidth = 12

With ActiveSheet.PageSetup
.FitToPagesTall = False
.FitToPagesWide = 1
.Zoom = False
.PrintTitleRows = ActiveSheet.Rows(1).Address
.PrintArea = ActiveSheet.UsedRange.Address
End With

ActiveSheet.PrintPreview

End Sub
[/VBA]

[mdmackillop]

Hi Wibbers,
I've done this so often manually, its time I had a solution for myself, so here's a general solution for an automatic or defined horizontal break. It assumes data starts in A1 and forms a solid block of data to the right and down.
Regards
MD
[VBA] Option Explicit
Sub Splits()
Dim Rw As Long, Rws As Long, Cols As Long, Sets As Long
Dim i As Long, j As Long, k As Long, Blanks As Long
Dim Data As Range

Blanks = InputBox("Enter intervening blank columns required", "Spacing", 0)

Application.ScreenUpdating = False
Cells(1, 1).Select
Set Data = Range(Cells(1, 1), Cells(1, 1).End(xlToRight))
Cols = Data.Columns.Count + Blanks
If Cols > 255 Then Cols = 1 + Blanks

Rws = Range("A1").End(xlDown).Row()
Rw = ActiveSheet.HPageBreaks(1).Location.Row() - 1
Sets = (Rws / Rw) + 1

For k = 1 To Sets
For j = 1 To Cols
For i = 1 To Rw
Cells(i, k * Cols + j) = Cells(k * Rw + i, j)
Next
Next
Next

Range(Cells(Rw + 1, 1), Cells(Rws, Cols)).ClearContents

Set Data = Nothing
Application.ScreenUpdating = True
End Sub

[/VBA]

[wibbers2000]

thanks this has done just as requested. thanks


just need to look at the code to see how its doing it.

Wibbers