CODEWITHSUNDEEP
vbaexcel
Chetan Risbud
Chetan Risbud

Reputation: 13

Copy Rows into columns using VBA

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

Input File

Desired Output

Desired Output

Sample data

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

Output obtained by Code

Desired output

Desired output

Upvotes: 0

Views: 5588

Answers (3)

cyberponk
cyberponk

Reputation: 1766

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

Upvotes: 1

J_Lard
J_Lard

Reputation: 1103

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

Upvotes: 0

cyberponk
cyberponk

Reputation: 1766

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

Upvotes: 0

Related Questions