Copy Rows into columns using VBA - 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

Answer 1

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

Answer 2

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

Answer 3

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