Selected Answer
This is the code that does what you ask. In the attached workbook it's in the standard code module TXL_5448.
Sub TransposeDate()
' 249
Const TabName As String = "Output" ' change to suit
Dim WsS As Worksheet ' Source: Worksheet to read from
Dim WsT As Worksheet ' Target: Worksheet to write to
Dim Caps As Variant ' captions: header row (years)
Dim Data As Variant ' one row of data
Dim Cl As Long ' column: last used (in caption row)
Dim Rt As Long ' target row
Dim Rs As Long ' loop counter: source rows
On Error Resume Next
Set WsT = Worksheets(TabName)
If Err Then ' create worksheet if it doesn't exist
Set WsS = ActiveSheet
Set WsT = Worksheets.Add
WsT.Name = TabName
WsS.Activate
End If
Application.ScreenUpdating = False
Set WsS = Worksheets("Sheet1 (2)") ' change tab name as required
With WsS
Rt = 2 ' captions row: change to suit
Cl = .Cells(Rt, .Columns.Count).End(xlToLeft).Column
Caps = .Range(.Cells(Rt, 1), .Cells(Rt, Cl)).Value
' change start row (= Rt + 1) and measure column to suit
For Rs = Rt + 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
Data = .Range(.Cells(Rs, 1), .Cells(Rs, Cl)).Value
With WsT
' change column to write to here:-
Rt = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(Rt, "A").Resize(UBound(Caps, 2), UBound(Caps)).Value = Application.Transpose(Caps)
.Cells(Rt, "B").Resize(UBound(Data, 2), UBound(Data)).Value = Application.Transpose(Data)
End With
Next Rs
End With
Application.ScreenUpdating = True
WsT.Activate
End Sub
There are lots of parameters that you can change. Please pay attention to the comments within the code.
Edit (V. 210529): ==================================
The code now has a lot of constants which you can change. For example, DataClm = 7 in my workbook but it's 5 in your request. You can change this. Also, your sample data don't allow for captions and titles. Space for them can be created by setting different constants.