insert page breaks every 43 lines

  • Thread starter Thread starter chase
  • Start date Start date
C

chase

the code below works to transpose data to a sheet called "All".

however, i've tried several ways of inserting pagebreaks for every 43
rows of transposed data on sheet "All".

any suggestions?

thanks,
chase


Public Sub TransposeToOneColumn()
Dim sourceSht As Worksheet
Dim destSht As Worksheet
Dim destRow As Long
Dim cell As Range
Dim Counter As Integer

Worksheets("All").ResetAllPageBreaks

Application.ScreenUpdating = False

Set sourceSht = Worksheets("Projects")
Set destSht = Worksheets("All")
destRow = 1

For Each cell In sourceSht.Range("A4:A" & Range("A" & _
Rows.Count).End(xlUp).Row)

cell.Resize(, 43).Copy
destSht.Range("B" & destRow).PasteSpecial Transpose:=True

sourceSht.Range("A2:AQ2").Copy
destSht.Range("A" & destRow).PasteSpecial Transpose:=True

destRow = destRow + 43

Next cell

Sheets("All").Activate
Columns("B:B").Select
Selection.ColumnWidth = 55
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Columns("A:A").Select
Selection.ColumnWidth = 32
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Rows(44).PageBreak = xlManual

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
 
Chase,

try

Dim x As Long
Dim lrow As Long

lrow = Cells(Rows.Count, "A").End(xlUp).Row
x = 0
Do Until x > lrow
x = x + 44
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Rows(x)
Loop

steve
 
Back
Top