Transpose Rows Into Columns

Got any Excel/VBA Questions? Free Excel Help

Transpose Single Column List Into X Columns

Sub TransposeRows()

Dim lRows As Long, lCol As Long

Dim rCol As Range

Dim lLoop As Long

Dim wsStart As Worksheet, wsTrans As Worksheet





    On Error Resume Next

    'Get single column range

    Set rCol = Application.InputBox(Prompt:="Select single column", _
                                    Title:="TRANSPOSE ROWS", Type:=8)

                                    

    'Cancelled or non valid range

    If rCol Is Nothing Then Exit Sub

    

    lRows = Application.InputBox(Prompt:="Transpose every x rows", _
                                        Title:="TRANSPOSE ROWS", Type:=2)

                                    

    'Cancelled

    If lRows = 0 Then Exit Sub

                                    

    'Make sure the transpositions will fit

    If lRows > ActiveSheet.Columns.Count Then

        MsgBox "Your 'transpose every x rows' exceeds the columns available"

        Exit Sub

    End If

    

    'Limit range to used cells

    lCol = rCol.Column

    Set rCol = Range(rCol(1, 1), Cells(Rows.Count, lCol).End(xlUp))

    

    'Set Worksheet variables

    Set wsStart = ActiveSheet

    Set wsTrans = Sheets.Add()

    wsStart.Select

    

    'Loop with step of x and transpose

    For lLoop = rCol(1, 1).Row To Cells(Rows.Count, lCol).End(xlUp).Row Step lRows

            Cells(lLoop, lCol).Resize(lRows, 1).Copy

            wsTrans.Cells(Rows.Count, "A").End(xlUp)(2, 1).PasteSpecial Transpose:=True

            Application.CutCopyMode = False

    Next lLoop

    

    On Error GoTo 0

End Sub