Sub MyCopyData()
Dim src As Worksheet
Dim dst As Worksheet
Dim lr As Long
Dim r As Long
Dim lc As Long
Dim rd As Long
Application.ScreenUpdating = False
' Set source and destination sheets
Set src = Sheets("Sheet1")
Set dst = Sheets("Sheet2")
' Find last row with data in column A on source sheet
lrow = src.Cells(Rows.Count, "A").End(xlUp).Row
src.Activate
' Loop through all data
For r = 1 To lrow
' Find last row with data on destination sheet
If dst.Cells(1, "A") = "" Then
rd = 1
Else
rd = dst.Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
' Copy column A to column A
src.Cells(r, "A").Copy dst.Cells(rd, "A")
' Find last column with data in row
lc = src.Cells(r, Columns.Count).End(xlToLeft).Column
' Copy paste transpose rest of data
src.Range(Cells(r, 2), Cells(r, lc)).Copy
dst.Cells(rd, "B").PasteSpecial Transpose:=True
Application.CutCopyMode = False
' Fill in the rest of column A
If lc > 2 Then
Range(dst.Cells(rd + 1, "A"), dst.Cells(rd + lc - 2, "A")) = dst.Cells(rd, "A")
End If
Next r
Application.ScreenUpdating = True
End Sub