Excel VBA Macro to Transpose Rows

Let us consider that a single column a contains data like below

Column A

L.saravanan
Data engineer
karaikkudi
Drk.kKarthikeyan
Ceo
Karaikkudi

if we transpose every three rows into column we get a valid data like below

ColumnA      ColumnB          ColumnC

L.saravnan    Data Engineer   Karaikkudi
Dr.K.K          Ceo                   Karaikuddi


Do it automatically we need a macro to transpose rows:-

1. Right click sheet one and click view code
2. Copy the below code and paste it.
3. Click return back to Microsoft excel from Vb Window
4. Now click view from excel ribbon
5. Click view macro
6. Click run Transpose macro
7. Enter A1 and click ok
8. Now enter number of rows to be transposed
9. Click ok and witness the magic of code

Transpose Row Macro:-

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

I think this will be useful to you friends.