Paul,

You are welcome and now for the "fixes".
I went a bridge too far...Excel is limited to approximately
1024 page breaks ( at least thru xl2002).
So you cannot do 1500 pages all in one go.

I've modified the code to limit the number of
rows to transpose to 1000 and made a few "improvements".
(Indicated by ***)
Be aware, with 1000 manual page breaks, it is going to run slow.

Regards,
Jim Cone

'----------------------------------------------------
Sub RowsToSeparatePages_1()
' Transposes each row in user specified data area
' into the first column on a new worksheet.
' Assumes data starts in Column A.
' User specifies the number of rows that each
' printable page will take and the first row with data.
' A page break is inserted to force the printing of separate pages.
' Jim Cone - San Francisco, USA - Feb 16, 2005
On Error GoTo ExitProcess
Dim lngRowIncrement As Long
Dim varRowSpacing As Variant
Dim varFirstRow As Variant
Dim rngRow As Excel.Range
Dim rngActual As Excel.Range
Dim rngToMove As Excel.Range

'Get information from the user.
'Rows per page should be = than the max
'number of columns with data.
varRowSpacing = InputBox("Enter number of rows per page.", _
" Rows to Pages", "Enter here")
varRowSpacing = Abs(Val(varRowSpacing))
'If no entry then quit
If varRowSpacing = 0 Then Exit Sub '***
varFirstRow = InputBox("Enter the start row.", _
" Rows to Pages", "Enter here")
varFirstRow = Abs(Val(varFirstRow))
'If no entry then quit
If varFirstRow = 0 Then Exit Sub '***

Application.ScreenUpdating = False
'Create a copy of the active sheet.
ActiveSheet.Copy After:=ActiveSheet
Columns("A").Insert
'Find the cells on the worksheet with the data.
'Calls Function BottomRightCorner
Set rngToMove = Range(Cells(varFirstRow, 2), _
BottomRightCorner(ActiveSheet, varFirstRow)) '***
'Go thru each row in the data area and transpose into the first column.
For Each rngRow In rngToMove.Rows
'Find the actual cells with data
Set rngActual = Range(rngRow.Cells(1), _
rngRow.Cells(1, rngRow.Cells.Count + 1).End(xlToLeft))
rngActual.Copy
Cells(varFirstRow + lngRowIncrement, 1).PasteSpecial Transpose:=True
lngRowIncrement = lngRowIncrement + varRowSpacing
Rows(lngRowIncrement + varFirstRow).PageBreak = xlPageBreakManual
ActiveSheet.DisplayPageBreaks = False
Application.StatusBar = "Working " & _
Format$(rngRow.Row / rngToMove.Rows.Count, "00%") '***
Next 'rngRow
rngToMove.Clear
ExitProcess:
On Error Resume Next
Cells(varFirstRow, 1).Select
Application.CutCopyMode = False
Application.StatusBar = False
Application.ScreenUpdating = True
Set rngRow = Nothing
Set rngActual = Nothing
Set rngToMove = Nothing
End Sub

'---------------------------------------------------------------
Function BottomRightCorner(ByRef objSheet As Worksheet, _
ByVal TopRow As Long) As Range '***
On Error GoTo NoCorner
Dim BottomRow As Long
Dim LastColumn As Long
If objSheet.FilterMode Then objSheet.ShowAllData
BottomRow = objSheet.Cells.Find(what:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
BottomRow = WorksheetFunction.Min(BottomRow, TopRow + 1000) '***
LastColumn = objSheet.Cells.Find(what:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set BottomRightCorner = objSheet.Cells(BottomRow, LastColumn)
Exit Function
NoCorner:
Beep
Set BottomRightCorner = objSheet.Cells(1, 1)
End Function
'-----------------------------------------------------------



"PaulFincannon"
wrote in message ...

Thanks so much Jim, I will give it a try tonight! You went above and
beyond!


--
PaulFincannon