VBA to Transpose Data and Loop

Apotts85

New Member
Joined
Apr 26, 2018
Messages
4
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;
IndexBudget View1/1/20182/1/20183/1/20184/1/2018
123Budget$10.00$10.00$10.00$10.00
123Forecast$10.00$0.00$5.00$5.00

<tbody>
</tbody>

I need a code that will loop through each row to transform the information into this format. Any help is greatly appreciated. Thanks.
IndexBudget ViewDateAmount
123Budget1/1/2018$10.00
123Budget2/1/2018$10.00
123Budget3/1/2018$10.00
123Budget4/1/2018$10.00
123Forecast1/1/2018$10.00
123Forecast2/1/2018$0.00
123Forecast3/1/2018$5.00
123Forecast4/1/2018$5.00

<tbody>
</tbody>
 

Some videos you may like

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

Jerry Sullivan

MrExcel MVP
Joined
Mar 18, 2010
Messages
8,787
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

New Member
Joined
Apr 26, 2018
Messages
4
Thank you Jerry, that's exactly the tool I need to reformat. Appreciate your help.
 

Leith Ross

Well-known Member
Joined
Mar 17, 2008
Messages
1,874
Office Version
  1. 2010
  2. 2007
Platform
  1. Windows
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.

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

New Member
Joined
Apr 26, 2018
Messages
4

ADVERTISEMENT

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

Well-known Member
Joined
Mar 17, 2008
Messages
1,874
Office Version
  1. 2010
  2. 2007
Platform
  1. Windows
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.

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

Leith Ross

Well-known Member
Joined
Mar 17, 2008
Messages
1,874
Office Version
  1. 2010
  2. 2007
Platform
  1. Windows
Hello Apotts85,

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

Watch MrExcel Video

Forum statistics

Threads
1,109,511
Messages
5,529,280
Members
409,859
Latest member
emperorgenghiskhan
Top