Thread: Macro to change sheet - Horizontal (Time Allocation) to Veritical (Tablular) format?

Option Explicit

Sub ReOrganize()
'Author:    Jerry Beaucaire
'Date:      9/15/2010
'Summary:   Reorganize a multivalue column database
'           into a single value per row database
'           First column(s) are duplicated

Dim LR  As Long     'last row of data, we start at the bottom
Dim Col As Long     'column to start reorganization
Dim Rw  As Long
Dim Num As Long     'number of values on each row to split down
Dim Titles As Boolean

'the column to start split down
    Col = 3

'Inquire if data has titles in row1
    Titles = True

Application.ScreenUpdating = False  'speed up execution
LR = Range("A" & Rows.Count).End(xlUp).Row  'last row with data

'From the bottom up, split data down
    For Rw = LR To (1 - Titles) Step -1
        Num = Cells(Rw, Columns.Count).End(xlToLeft).Column
        If Num > Col Then
            Cells(Rw + 1, "A").Resize(Num - Col).EntireRow.Insert xlShiftDown
            With Range(Cells(Rw, Col + 1), Cells(Rw, Num))
                .Copy
                Cells(Rw + 1, Col).PasteSpecial xlPasteAll, Transpose:=True
                .Clear
            End With
        End If
        If Rw = 1 Then Exit For
    Next Rw

'move extra titles down
    LR = Cells(Rows.Count, Col).End(xlUp).Row
    Range(Cells(2, Col), Cells(LR, Col)).Insert xlShiftToRight
    Range(Cells(1, Col), Cells(1, Num)).Copy
    Range(Cells(2, Col), Cells(LR, Col)).PasteSpecial xlPasteAll, Transpose:=True
    If Titles Then Range(Cells(1, Col + 1), Cells(1, Columns.Count)).Clear
   
'Duplicate values in beginning column(s)
    With Range("A1", Cells(LR, Col - 1))
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        .Value = .Value
    End With
    Range("C1:D1").Value = [{"StartDate","QTY"}]
    
Application.ScreenUpdating = True
End Sub

The macro above is based on the ReOrganize macro published here:

Rows to Columns - Part 1a