Copy Rows into columns using VBA

Question

I have a very little experience with VBA, and I would really appreciate any help with this issue. I need to convert rows into columns from sheet 1 to sheet 2.

Input File

Desired Output

Sample data

My Code

Sub TransposeSpecial()

    Dim lMaxRows As Long 'max rows in the sheet
    Dim lThisRow As Long 'row being processed
    Dim iMaxCol As Integer 'max used column in the row being processed

    lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row

    lThisRow = 2 'start from row 2

    Do While lThisRow <= lMaxRows

        iMaxCol = Cells(lThisRow, Columns.Count).End(xlToLeft).Column

        If (iMaxCol > 1) Then
            Rows(lThisRow + 1 & ":" & lThisRow + iMaxCol - 1).Insert
            Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Copy
            Range("C" & lThisRow + 1).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Clear
            lThisRow = lThisRow + iMaxCol - 1
            lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
        End If

        lThisRow = lThisRow + 1
    Loop
End Sub

Output obtained by Code

Desired output

Copy the row you want to transpose, then select the first cell of the column you want to paste it to and paste it with option Transpose:= true. For a more detailed description, see this answer: http://stackoverflow.com/a/13175468/7061437 — nvkrj, Nov 03 '16 at 18:39
You probably don't need VBA for this. Just copy the cells and then right click and paste special -> transpose. — J_Lard, Nov 03 '16 at 18:41
@J_Lard Direct copy pasting is not possible due to required format. I need row by row transposed data in columns — Chetan Risbud, Nov 03 '16 at 18:52
What code have you written so far, and what part of that code is not working as you expect it to? — YowE3K, Nov 03 '16 at 19:21

score 1 · Accepted Answer · answered Nov 04 '16 at 19:24

Here you go, I made this flexible code. Just update the variables in the beginning.

Sub Transpose_my_cells()
  Dim rng As Range
  Dim sheet1, sheet2, addr As String
  Dim src_top_row, src_left_col, dst_top_row, dst_left_col, data_cols, y As Integer
  Application.ScreenUpdating = False


    sheet1 = "Sheet1"    'Put your source sheet name here
    sheet2 = "Sheet2"    'Put your destiny sheet name here

    src_top_row = 1     'Put the top row number of the source here
    src_left_col = 1    'Put the left col number of the source here

    dst_top_row = 1     'Put the top row number of the destiny here
    dst_left_col = 1    'Put the left col number of the destiny here

    'Count data columns
    data_cols = 0
    Do Until Worksheets(sheet1).Cells(src_top_row, src_left_col + data_cols + 1) = ""
        data_cols = data_cols + 1
    Loop

    'start copying data
    With Worksheets(sheet1)
    'first header
        .Cells(src_top_row, src_left_col).Copy
        addr = Cells(dst_top_row, dst_left_col).Address
        Worksheets(sheet2).Range(addr).PasteSpecial

        y = 0
            'loop for each source row
            Do Until .Cells(src_top_row + y + 1, src_left_col) = ""

                'Create First column repetitions
                .Cells(src_top_row + y + 1, src_left_col).Copy
                addr = Cells(dst_top_row + y * data_cols + 1, dst_left_col).Address & ":" & Cells(dst_top_row + y * data_cols + data_cols, dst_left_col).Address
                Worksheets(sheet2).Range(addr).PasteSpecial

                'Transpose Data Headers
                addr = Cells(src_top_row, src_left_col + 1).Address & ":" & Cells(src_top_row, src_left_col + data_cols).Address
                .Range(addr).Copy
                Worksheets(sheet2).Cells(dst_top_row + y * data_cols + 1, dst_left_col + 1).PasteSpecial Transpose:=True

                'Transpose Data columns
                Set rng = Cells(src_top_row + y + 1, src_left_col + 1)
                addr = rng.Address & ":" & rng.Offset(0, data_cols - 1).Address
                .Range(addr).Copy
                Worksheets(sheet2).Cells(dst_top_row + y * data_cols + 1, dst_left_col + 2).PasteSpecial Transpose:=True
                y = y + 1
            Loop

    End With

  Application.ScreenUpdating = True
End Sub

Thank you so much it works great and help me a lot to understand loops i am very weak in loops. — Chetan Risbud, Nov 07 '16 at 06:06

score 0 · Answer 2 · answered Nov 03 '16 at 18:51

0

Using VBA:

Sub Transpose_my_cells()
    Worksheets("Sheet1").Range("A1:E1").Copy
    Worksheets("Sheet2").Range("A1").PasteSpecial Transpose:=True

End Sub

Notes:

Change Sheet1 and Sheet2 with your sheet names as shown in the VBA sheet list.
change A1:E1 to the source cell range
change A1 to the destiny top cell

answered Nov 03 '16 at 18:51

cyberponk

1,585
18
19

A straight transpose of the data is not what the OP wants. It is closer to an Un-Pivot. – Scott Craner Nov 03 '16 at 18:55
@cyberponk Direct copy pasting is not possible due to required format. I need row by row transposed data in columns – Chetan Risbud Nov 03 '16 at 18:59

score 0 · Answer 3 · answered Nov 04 '16 at 13:32

There is probably a much easier/cleaner way to do this but it works. The way it's written now, it will take the data in Sheet1 and output the transposed data on Sheet2. It should work as long as your data starts in cell A1.

Option Explicit

Sub transpose()

    Dim names() As String
    Dim count As Long
    Dim i As Long
    Dim j As Long
    Dim rng As Range
    Dim tmp As Long

    Sheets("Sheet1").Activate

    count = 0
    With ThisWorkbook.Sheets("Sheet1")
        Do Until .Cells(1, 2 + count) = ""
            count = count + 1
        Loop

        ReDim names(0 To count - 1)
        count = 0
        Do Until .Cells(1, 2 + count) = ""
            names(count) = .Cells(1, 2 + count).Value
            count = count + 1
        Loop
        .Range("A2").Activate
        Set rng = Range(Selection, Selection.End(xlDown))
    End With

    j = 0
    With ThisWorkbook.Sheets("Sheet2")
        .Cells(1, 1).Value = "ID"
        .Cells(1, 2).Value = "Name"
        .Cells(1, 3).Value = "Value"
        For i = 0 To rng.count * count - 1
            If i Mod count = 0 Then
                j = j + 1
                Range(Cells(j + 1, 2), Cells(j + 1, count + 1)).Copy
                .Cells(i + 2, 3).PasteSpecial transpose:=True
            End If
            .Cells(i + 2, 1).Value = rng(j).Value
            .Cells(i + 2, 2).Value = names(i Mod count)
        Next i
        .Activate
    End With

End Sub

Copy Rows into columns using VBA

3 Answers3

Linked