Convert table columns to flat list rows

Happens quite often, you have a nice table with data in columns (eg. in months, quarters, years, etc), which you need to convert into a list (eg. for pivots).

This macro does the trick, I have used a macro I found online as a basis, and modified it so you only enter the number of fixed columns, and it will create rows for all of the others.

Option Explicit
Sub ColumnsToRows()
Dim a As Variant, b As Variant
Dim i As Long, ii As Long, C As Long, lc As Long, Y As Long, R As Long
Dim x As Range

With ActiveSheet
Application.ScreenUpdating = False

‘Define the number of fixed columns to repeat (all other columns will be defined as new rows)
Y = 7

‘Copy the headers of your fixed columns
Set x = .Range("A1").CurrentRegion.Resize(, Y)

‘Define the range
a = .Cells(1).CurrentRegion

‘Define the last column of the range
lc = .Cells(1, Columns.Count).End(xlToLeft).Column

ReDim b(1 To (UBound(a, 1) * 12) + 1, 1 To Y + 2)
End With

‘Start the action!
For i = 2 To UBound(a, 1)
For C = Y + 1 To lc
ii = ii + 1
For R = 1 To Y
b(ii, R) = a(i, R)
Next R
b(ii, Y + 1) = a(1, C)
b(ii, Y + 2) = a(i, C)
Next C
Next i

‘Put output in sheet ‘results’, create it if it doesn’t exist
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=ActiveSheet).Name = "Results"
With Sheets("Results")
.Cells(1, 1).Resize(, Y).Value = x.Value
.Cells(1, Y + 1).Resize(, 2).Value = [{"Period","Amount"}]
.Cells(2, 1).Resize(UBound(b, 1), UBound(b, 2)) = b
End With
Application.ScreenUpdating = True
End Sub

Base source: here