Help to extract data in certain format

[Paul at GTS]

Hi Guys can you help me ?

I have data on a worksheet as below

Product Date1 Date2 Date3
Apple 2 4 0
Banana 1 3 4


I need to get the data in the form, I have around 11000 rows. Using Excel from Office 365 Version 1711 Build 8730.2175

Apple Date1 2
Apple Date2 4
Apple Date3 0
Banana Date1 1
Banana Date2 3
Banana Date3 4

Thanks

 

[Fluff]

How about

Sub CopyTranspose()

   Dim Hdrs As Variant
   Dim Cl As Range
   Dim SrcWs As Worksheet
   Dim DestWs As Worksheet
   
   Set SrcWs = Sheets("[COLOR=#ff0000]Data[/COLOR]")
   Set DestWs = Sheets("[COLOR=#ff0000]Sheet3[/COLOR]")
   
   Hdrs = Application.Transpose(SrcWs.Range("B1", SrcWs.Cells(1, Columns.Count).End(xlToLeft)))
   For Each Cl In SrcWs.Range("A2", SrcWs.Range("A" & Rows.Count).End(xlUp))
      With DestWs.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(Hdrs, 1))
         .Value = Cl.Value
         .Offset(, 1).Value = Hdrs
         .Offset(, 2).Value = Application.Transpose(Cl.Offset(, 1).Resize(, UBound(Hdrs, 1)).Value)
      End With
   Next Cl
End Sub

Change sheet names in red to suit