insert page breaks every 43 lines
 

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

insert page breaks every 43 lines
 

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 Befo=Rows(x)
Loop

steve

"chase" wrote in message
om...
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

insert page breaks every 43 lines
 

Steve,

works great. MUCHISIMAS GRACIAS!