Sub RowsToColumns()
Dim rCol As Range
Dim rCell1 As Range, rCell2 As Range
Dim i As Integer, iPBcount As Integer
Dim Sht As Worksheet
Application.StatusBar = "Converting, please wait....!"
Application.ScreenUpdating = False
'Set range variable to Selection
Set Sht = ActiveSheet
Set rCol = Sht.UsedRange.Columns(1)
'Insert page breaks
Sht.PageSetup.PrintArea = ""
Sht.PageSetup.Zoom = 100
ActiveWindow.View = xlPageBreakPreview
'Count only horizontal page breaks and pass to an Integer
iPBcount = Sht.HPageBreaks.Count
On Error Resume Next
'Loop as many times as there horizontal page breaks.
For i = 1 To iPBcount
'Set variable 1 to page break X
Set rCell1 = Sht.HPageBreaks(i).Location
'Set variable 2 to X page break
Set rCell2 = Sht.HPageBreaks(i + 1).Location.Offset(-1, 0)
If rCell2 Is Nothing Then 'Last page break
Range(rCell1, rCol.Cells(65536, 1).End(xlUp)).Cut _
Destination:=Sht.Cells(1, i + 1)
Else
Range(rCell1, rCell2).Cut Destination:=Sht.Cells(1, i + 1)
End If
Set rCell1 = Nothing
Set rCell2 = Nothing
Next i
On Error GoTo 0
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
Sht.DisplayPageBreaks = False
Application.Goto rCol.Cells(1, 1), True
Set rCol = Nothing
Application.StatusBar = ""
End Sub
Dim rCol As Range
Dim rCell1 As Range, rCell2 As Range
Dim i As Integer, iPBcount As Integer
Dim Sht As Worksheet
Application.StatusBar = "Converting, please wait....!"
Application.ScreenUpdating = False
'Set range variable to Selection
Set Sht = ActiveSheet
Set rCol = Sht.UsedRange.Columns(1)
'Insert page breaks
Sht.PageSetup.PrintArea = ""
Sht.PageSetup.Zoom = 100
ActiveWindow.View = xlPageBreakPreview
'Count only horizontal page breaks and pass to an Integer
iPBcount = Sht.HPageBreaks.Count
On Error Resume Next
'Loop as many times as there horizontal page breaks.
For i = 1 To iPBcount
'Set variable 1 to page break X
Set rCell1 = Sht.HPageBreaks(i).Location
'Set variable 2 to X page break
Set rCell2 = Sht.HPageBreaks(i + 1).Location.Offset(-1, 0)
If rCell2 Is Nothing Then 'Last page break
Range(rCell1, rCol.Cells(65536, 1).End(xlUp)).Cut _
Destination:=Sht.Cells(1, i + 1)
Else
Range(rCell1, rCell2).Cut Destination:=Sht.Cells(1, i + 1)
End If
Set rCell1 = Nothing
Set rCell2 = Nothing
Next i
On Error GoTo 0
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
Sht.DisplayPageBreaks = False
Application.Goto rCol.Cells(1, 1), True
Set rCol = Nothing
Application.StatusBar = ""
End Sub
No comments:
Post a Comment