Converting Rows to Columns?

[PaulFincannon]

Hi,

I ran a report which concluded with 1500 lines of data. I would like
to convert each row to a column, which I know how to do using paste
special and transpose. However, is there a way to convert each row so
that it will appear on a different print page without having to
transpose each row individually per page? Thanks in advance!

Puzzled Paul

 

[Guest]

Hi Paul-

I've hesitated to reply because I'm a little confused by your post. Since
you've had no other responses, I'll be glad to try if you can please clarify
for me:

a) re transposing 1500 lines (rows?) to columns with only 256 columns
allowed per sheet,

b) re "convert each row so that it will appear on a different print page
without having to transpose each row individually per page?". Do you want to
print each row of data on a separate page?, columns as rows?

Thanks for the feedback |:>)

 

[Jim Cone]

Paul,
The following code does what I interpreted you to want...
If you have 1500 rows of data then you will get 1500 pages to print.

Regards,
Jim Cone
San Francisco, USA

'--------------------------------------------------------------------------
Sub RowsToSeparatePages()
' 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 Len(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 Len(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))

'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
Next 'rngRow
rngToMove.Clear
ExitProcess:

On Error Resume Next
Application.CutCopyMode = False
Cells(varFirstRow, 1).Select
Application.ScreenUpdating = True
Set rngRow = Nothing
Set rngActual = Nothing
Set rngToMove = Nothing
End Sub

'---------------------------------------------------------------
Function BottomRightCorner(ByRef objSheet As Worksheet) 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
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]

Thanks much for the reply, CyberTaz, I really appreciate it. Sorry for
my muddled info. Yes, I have 1500 rows of information that someone
wants in column form, one row converted to a column for each page. I
found out about the 256 column limitation when I tried to paste
special/transpose the document. My goal is for each of the rows to be
converted to a column, with one column on each page. Many thanks for
the offer of help!

Paul

 

[PaulFincannon]

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

 

[Jim Cone]

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
'-----------------------------------------------------------