Friday, February 24, 2012

Print a long Column of data:

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

No comments:

Post a Comment