VBA code to make date in vertical format

[deepakga123]

Hi Team,

Appreciate if I get VBA code for the below data.

In the below 1st image I have data in below format and I need automate this to bring in vertical format like in 2nd image in new sheet.
Code should be dynamic so that I can convert huge data in vertical format in single click.
Thanks in Advance.

 

[Fluff]

How about

Sub deepakga()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 3)
   
   For c = 2 To UBound(Ary, 2)
      For r = 2 To UBound(Ary)
         nr = nr + 1
         Nary(nr, 1) = Ary(1, c)
         Nary(nr, 2) = Ary(r, 1)
         Nary(nr, 3) = Ary(r, c)
      Next r
   Next c
   Range("J2").Resize(nr, 3) = Nary
End Sub

 

[deepakga123]

How about

Sub deepakga()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
 
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 3)
 
   For c = 2 To UBound(Ary, 2)
      For r = 2 To UBound(Ary)
         nr = nr + 1
         Nary(nr, 1) = Ary(1, c)
         Nary(nr, 2) = Ary(r, 1)
         Nary(nr, 3) = Ary(r, c)
      Next r
   Next c
   Range("J2").Resize(nr, 3) = Nary
End Sub

Thank You Fluff,
The code is doing what I exactly wanted

 

[Fluff]

You're welcome & thanks for the feedback.

 

[DanteAmor]

Here is another macro for you to consider.
Data on sheet1, results on sheet2

Sub date_in_vertical()
  Dim i As Long, j As Long, lr As Long, lr2 As Long
 
  With Sheets("Sheet1")
    lr = .Range("A" & Rows.Count).End(3).Row
    For j = 2 To .Cells(1, Columns.Count).End(1).Column
      lr2 = Sheets("Sheet2").Range("A" & Rows.Count).End(3)(2).Row
      Sheets("Sheet2").Range("A" & lr2).Resize(lr - 1).Value = .Cells(1, j).Value
      Sheets("Sheet2").Range("B" & lr2).Resize(lr - 1).Value = .Range("A2:A" & lr).Value
      Sheets("Sheet2").Range("C" & lr2).Resize(lr - 1).Value = .Range(.Cells(2, j), .Cells(lr, j)).Value
    Next
  End With
End Sub

 

[deepakga123]

Here is another macro for you to consider.
Data on sheet1, results on sheet2

Sub date_in_vertical()
  Dim i As Long, j As Long, lr As Long, lr2 As Long

  With Sheets("Sheet1")
    lr = .Range("A" & Rows.Count).End(3).Row
    For j = 2 To .Cells(1, Columns.Count).End(1).Column
      lr2 = Sheets("Sheet2").Range("A" & Rows.Count).End(3)(2).Row
      Sheets("Sheet2").Range("A" & lr2).Resize(lr - 1).Value = .Cells(1, j).Value
      Sheets("Sheet2").Range("B" & lr2).Resize(lr - 1).Value = .Range("A2:A" & lr).Value
      Sheets("Sheet2").Range("C" & lr2).Resize(lr - 1).Value = .Range(.Cells(2, j), .Cells(lr, j)).Value
    Next
  End With
End Sub

Thank You DanteAmor Appreciate your help

 

[DanteAmor]

Glad we could help & thanks for the feedback