Here is a solution using Arrays. In the code, there are couple of static ranges. So you will need to set the sheet name, starting cell names accordingly.
Option Explicit
Sub colsToRows()
Dim ws1 As Worksheet
Dim a As Long, lr As Long, lc As Long
Dim va As Variant, vd As Variant
Dim LastRow As Long, LastCol As Long
'-- set e.g. sheet name Sheet1, starting column = B, dates starting cell = C2
Set ws1 = Sheets("Sheet1")
LastRow = ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row
LastCol = ws1.Cells(Range("C2").Row, ws1.Columns.Count).End(xlToLeft).Column - 1
'--put dates into this array as it repeats for each item
vd = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ws1.Range("C2").Resize(1, LastCol - 1)))
'-- titles
ws1.Range("B2").Offset(LastRow + 1) = "Item"
ws1.Range("C2").Offset(LastRow + 1) = "Dates"
ws1.Range("D2").Offset(LastRow + 1) = "Data"
'--2 is deducted as the main range is starting from B3. So B3-B1 = 2
For a = 1 To LastRow - 2
'--to get next last row
lr = Cells(Rows.Count, "B").End(xlUp).Row
'--items
va = Array(ws1.Range("B2").Offset(a).Value)
ws1.Range("B1").Offset(lr).Resize(LastCol - 1) = Application.Transpose(va)
'--dates
ws1.Range("C1").Offset(lr).Resize(UBound(vd)) = Application.Transpose(vd)
'--data
va = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ws1.Range("C2").Offset(a).Resize(1, LastCol - 1)))
ws1.Range("D1").Offset(lr).Resize(UBound(va)) = Application.Transpose(va)
Next a
End Sub
Output:
