VBA code to make date in vertical format

deepakga123

Board Regular
Joined
Jan 5, 2012
Messages
50
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.

1st Image.PNG


2nd  Image.PNG
 

Some videos you may like

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,071
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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

Board Regular
Joined
Jan 5, 2012
Messages
50
How about
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,071
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

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

VBA Code:
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

Board Regular
Joined
Jan 5, 2012
Messages
50
Here is another macro for you to consider.
Data on sheet1, results on sheet2

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Glad we could help & thanks for the feedback
 

Watch MrExcel Video

Forum statistics

Threads
1,122,826
Messages
5,598,327
Members
414,229
Latest member
Josu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top