VBA to Transpose Data and Loop

[Apotts85]

Hello Excel Gurus,

I'm trying to write a code that will transform my data from singular columns to multiple rows. My data is currently organized like this;
[TABLE="width: 500"]
<tbody>[TR]
[TD]Index[/TD]
[TD]Budget View[/TD]
[TD]1/1/2018[/TD]
[TD]2/1/2018[/TD]
[TD]3/1/2018[/TD]
[TD]4/1/2018[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Budget[/TD]
[TD]$10.00[/TD]
[TD]$10.00[/TD]
[TD]$10.00[/TD]
[TD]$10.00[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Forecast[/TD]
[TD]$10.00[/TD]
[TD]$0.00[/TD]
[TD]$5.00[/TD]
[TD]$5.00[/TD]
[/TR]
</tbody>[/TABLE]

I need a code that will loop through each row to transform the information into this format. Any help is greatly appreciated. Thanks.
[TABLE="width: 500"]
<tbody>[TR]
[TD]Index[/TD]
[TD]Budget View[/TD]
[TD]Date[/TD]
[TD]Amount[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Budget[/TD]
[TD]1/1/2018[/TD]
[TD]$10.00[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Budget[/TD]
[TD]2/1/2018[/TD]
[TD]$10.00[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Budget[/TD]
[TD]3/1/2018[/TD]
[TD]$10.00[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Budget[/TD]
[TD]4/1/2018[/TD]
[TD]$10.00[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Forecast[/TD]
[TD]1/1/2018[/TD]
[TD]$10.00[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Forecast[/TD]
[TD]2/1/2018[/TD]
[TD]$0.00[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Forecast[/TD]
[TD]3/1/2018[/TD]
[TD]$5.00[/TD]
[/TR]
[TR]
[TD]123[/TD]
[TD]Forecast[/TD]
[TD]4/1/2018[/TD]
[TD]$5.00[/TD]
[/TR]
</tbody>[/TABLE]

 

[Jerry Sullivan]

Welcome to MrExcel,

What you are describing is sometimes referred to as Unpivoting data.

What version of Excel are you using? If you have a version that supports Power Query, you can unpivot your data using the Get & Transform operations.

 

[Apotts85]

Thank you Jerry, that's exactly the tool I need to reformat. Appreciate your help.

 

[Leith Ross]

Hello Apotts85,

This macro will transpose the data as you requested. Them macro inputs the data from "Sheet1"and outputs the transposed data to "Sheet2". You can change the sheet names in the macro if you need to. It is assumed row 1 is the header row and the data starts at row 2 on both sheets.

Sub Transpose()


    Dim Data() As Variant
    Dim j       As Long
    Dim k       As Long
    Dim n       As Long
    Dim Rng     As Range
    Dim RngEnd  As Range
    Dim RngBeg  As Range
    Dim rowCnt  As Long
    Dim wksIn   As Worksheet
    Dim wksOut  As Worksheet
    
        Set wksIn = ThisWorkbook.Worksheets("Sheet1")
        Set wksOut = ThisWorkbook.Worksheets("Sheet2")
        
        Set RngBeg = wksIn.Range("A2")
        Set RngEnd = wksIn.Cells(Rows.Count, "A").End(xlUp)
        
        If RngEnd.row < RngBeg.row Then Exit Sub
            
        Set Rng = wksIn.Range(RngBeg, RngEnd)
        
            rowCnt = RngEnd.row - RngBeg.row + 1
            ReDim Data(1 To (rowCnt * 4), 1 To 4)
            
            For j = 1 To rowCnt
                For k = 0 To 3
                    n = n + 1
                    Data(n, 1) = Rng.Cells(j, 1)
                    Data(n, 2) = Rng.Cells(j, 2)
                    Data(n, 3) = wksIn.Cells(1, 3 + k)
                    Data(n, 4) = Rng.Cells(j, 3 + k)
                Next k
            Next j
        
        wksOut.Range("A2").Resize(n, 4).Value = Data
            
End Sub

 

[Apotts85]

Thank you so much Leith! This works perfectly. Would you mind also giving me the code for 12 months? Jan - Dec. Thanks again, you're a genius.

 

[Leith Ross]

Hello Apotts85,

It has been a hectic Friday but I finally got to the code. Here is the updated macro code. It will now work with any number of columns from "C"onward.

Sub Transpose()


    Dim colCnt  As Long
    Dim Data()  As Variant
    Dim j       As Long
    Dim k       As Long
    Dim n       As Long
    Dim Rng     As Range
    Dim RngEnd  As Range
    Dim RngBeg  As Range
    Dim RowCnt  As Long
    Dim WksIn   As Worksheet
    Dim WksOut  As Worksheet
    
        Set WksIn = ThisWorkbook.Worksheets("Sheet2")
        Set WksOut = ThisWorkbook.Worksheets("Sheet3")
        
        Set RngBeg = WksIn.Range("A2")
        Set RngEnd = WksIn.Cells(Rows.Count, "A").End(xlUp)
        
        If RngEnd.row < RngBeg.row Then Exit Sub
           
        colCnt = WksIn.Cells(1, Columns.Count).End(xlToLeft).Column - 2
        
        Set Rng = WksIn.Range(RngBeg, RngEnd)
        
            RowCnt = RngEnd.row - RngBeg.row + 1
            ReDim Data(1 To (RowCnt * colCnt), 1 To colCnt)
            
            For j = 1 To RowCnt
                For k = 0 To colCnt - 1
                    n = n + 1
                    Data(n, 1) = Rng.Cells(j, 1)
                    Data(n, 2) = Rng.Cells(j, 2)
                    Data(n, 3) = WksIn.Cells(1, 3 + k)
                    Data(n, 4) = Rng.Cells(j, 3 + k)
                Next k
            Next j
        
        WksOut.Range("A2").Resize(n, 4).Value = Data
            
End Sub

 

[Apotts85]

Thank you!

 

[Leith Ross]

Hello Apotts85,

You're welcome. Good to know it is working like you wanted.