none
Excel Macro to Transpose Vertical Data to Horizontal Data

    Question

  • Hi,

    I'm using Excel 2010, and I'm not extremely advanced when it comes to the macro side of Excel.  However, I currently have projects with different projects dates across multiple columns.  What I want to do is take these dates from a horizontal layout and transpose them into a vertical arrangement.

    Here is an example of the current data:

    And this is what I'm looking to achieve:

    I realize I'm probably going to have to create some sort of macro that can loop through each of these columns.  I'm not exactly sure how to do this or how to get started, but I was hoping someone would be able to provide me with a good starting point to accomplish this.  Thanks in advance!

    Wednesday, July 24, 2013 8:22 PM

Answers

  • Try this. I have inserted lots of comments. The macro creates a new sheet.

    Sub Transform()
        Const lngFirstRow = 1 ' First used row
        Const lngFirstCol = 1 ' First used column
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim lngRow As Long
        Dim lngCol As Long
        Dim lngLastRow As Long
        Dim lngLastCol As Long
        Dim lngRowT As Long
        ' Do not update screen
        Application.ScreenUpdating = False
        ' Reference to active sheet
        Set wshS = ActiveSheet
        ' Last used row
        lngLastRow = wshS.Cells(lngFirstRow + 1, lngFirstCol).End(xlDown).Row
        ' Last used column
        lngLastCol = wshS.Cells(lngFirstRow, lngFirstCol + 1).End(xlToRight).Column
        ' Create new sheet
        Set wshT = Worksheets.Add(After:=wshS)
        ' Fill first row
        wshT.Cells(1, 1) = "Project"
        wshT.Cells(1, 2) = "Date"
        ' Format column B as date
        wshT.Columns(2).NumberFormat = "m/d/yyyy"
        ' Row to start copying
        lngRowT = 2
        ' Loop through rows of source sheet
        For lngRow = lngFirstRow + 1 To lngLastRow
            ' Loop through columns of source sheet
            For lngCol = lngFirstCol + 1 To lngLastCol
                ' Check for date
                If IsDate(wshS.Cells(lngRow, lngCol).Value) Then
                    ' Copy project to column A
                    wshT.Cells(lngRowT, 1).Value = wshS.Cells(lngRow, lngFirstCol).Value
                    ' Copy date to column B
                    wshT.Cells(lngRowT, 2).Value = wshS.Cells(lngRow, lngCol).Value
                    ' Increase target row
                    lngRowT = lngRowT + 1
                End If
            Next lngCol
        Next lngRow
        ' Autofit columns
        wshT.Range("A1:B1").EntireColumn.AutoFit
        ' Update screen again
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar

    • Marked as answer by Jim Shorts Thursday, July 25, 2013 2:07 AM
    Wednesday, July 24, 2013 8:37 PM
  • Here you go:

    Sub Transform()
        Const lngFirstRow = 1 ' First used row
        Const lngFirstCol = 1 ' First used column
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim lngRow As Long
        Dim lngCol As Long
        Dim lngLastRow As Long
        Dim lngLastCol As Long
        Dim lngRowT As Long
        ' Do not update screen
        Application.ScreenUpdating = False
        ' Reference to active sheet
        Set wshS = ActiveSheet
        ' Last used row
        lngLastRow = wshS.Cells(lngFirstRow + 1, lngFirstCol).End(xlDown).Row
        ' Last used column
        lngLastCol = wshS.Cells(lngFirstRow, lngFirstCol + 1).End(xlToRight).Column
        ' Create new sheet
        Set wshT = Worksheets.Add(After:=wshS)
        ' Fill first row
        wshT.Cells(1, 1) = "Project Name"
        wshT.Cells(1, 2) = "Event Name"
        wshT.Cells(1, 3) = "Event Start"
        wshT.Cells(1, 4) = "Event End"
        ' Format columns C and D as date
        wshT.Range("C:D").NumberFormat = "m/d/yyyy"
        ' Row to start copying
        lngRowT = 2
        ' Loop through rows of source sheet
        For lngRow = lngFirstRow + 1 To lngLastRow
            ' Loop through columns of source sheet
            For lngCol = lngFirstCol + 2 To lngLastCol
                ' Check for date
                If IsDate(wshS.Cells(lngRow, lngCol).Value) Then
                    ' Copy project name to column A
                    wshT.Cells(lngRowT, 1).Value = wshS.Cells(lngRow, lngFirstCol).Value
                    ' Copy event name to column B
                    wshT.Cells(lngRowT, 2).Value = wshS.Cells(lngFirstRow, lngCol).Value
                    ' Copy event start to column C
                    wshT.Cells(lngRowT, 3).Value = wshS.Cells(lngRow, lngFirstCol + 1).Value
                    ' Copy event end to column D
                    wshT.Cells(lngRowT, 4).Value = wshS.Cells(lngRow, lngCol).Value
                    ' Increase target row
                    lngRowT = lngRowT + 1
                End If
            Next lngCol
        Next lngRow
        ' Autofit columns
        wshT.Range("A1:D1").EntireColumn.AutoFit
        ' Update screen again
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar

    • Marked as answer by Jim Shorts Thursday, July 25, 2013 1:22 PM
    Thursday, July 25, 2013 5:37 AM

All replies

  • Try this. I have inserted lots of comments. The macro creates a new sheet.

    Sub Transform()
        Const lngFirstRow = 1 ' First used row
        Const lngFirstCol = 1 ' First used column
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim lngRow As Long
        Dim lngCol As Long
        Dim lngLastRow As Long
        Dim lngLastCol As Long
        Dim lngRowT As Long
        ' Do not update screen
        Application.ScreenUpdating = False
        ' Reference to active sheet
        Set wshS = ActiveSheet
        ' Last used row
        lngLastRow = wshS.Cells(lngFirstRow + 1, lngFirstCol).End(xlDown).Row
        ' Last used column
        lngLastCol = wshS.Cells(lngFirstRow, lngFirstCol + 1).End(xlToRight).Column
        ' Create new sheet
        Set wshT = Worksheets.Add(After:=wshS)
        ' Fill first row
        wshT.Cells(1, 1) = "Project"
        wshT.Cells(1, 2) = "Date"
        ' Format column B as date
        wshT.Columns(2).NumberFormat = "m/d/yyyy"
        ' Row to start copying
        lngRowT = 2
        ' Loop through rows of source sheet
        For lngRow = lngFirstRow + 1 To lngLastRow
            ' Loop through columns of source sheet
            For lngCol = lngFirstCol + 1 To lngLastCol
                ' Check for date
                If IsDate(wshS.Cells(lngRow, lngCol).Value) Then
                    ' Copy project to column A
                    wshT.Cells(lngRowT, 1).Value = wshS.Cells(lngRow, lngFirstCol).Value
                    ' Copy date to column B
                    wshT.Cells(lngRowT, 2).Value = wshS.Cells(lngRow, lngCol).Value
                    ' Increase target row
                    lngRowT = lngRowT + 1
                End If
            Next lngCol
        Next lngRow
        ' Autofit columns
        wshT.Range("A1:B1").EntireColumn.AutoFit
        ' Update screen again
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar

    • Marked as answer by Jim Shorts Thursday, July 25, 2013 2:07 AM
    Wednesday, July 24, 2013 8:37 PM
  • Thank you so much for you help, Hans!  One other quick addition to this if you don't mind. There is actually one more column, let's say column B in this example, which lists the 'Start Date' for all these events.  Each event has the same start date but various end dates, which was represented above.  I would like to pull this 'Start Date' field into each row that is copied, along with the heading of each event column.  These headings will actually be the name of each event that is occuring, so the finished product would look like this:

    • Project Name   Event Name(column headings)   Event Start(column B)  Event End(already in the code you provided)

    Thank you for your time!

    Thursday, July 25, 2013 2:16 AM
  • Here you go:

    Sub Transform()
        Const lngFirstRow = 1 ' First used row
        Const lngFirstCol = 1 ' First used column
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim lngRow As Long
        Dim lngCol As Long
        Dim lngLastRow As Long
        Dim lngLastCol As Long
        Dim lngRowT As Long
        ' Do not update screen
        Application.ScreenUpdating = False
        ' Reference to active sheet
        Set wshS = ActiveSheet
        ' Last used row
        lngLastRow = wshS.Cells(lngFirstRow + 1, lngFirstCol).End(xlDown).Row
        ' Last used column
        lngLastCol = wshS.Cells(lngFirstRow, lngFirstCol + 1).End(xlToRight).Column
        ' Create new sheet
        Set wshT = Worksheets.Add(After:=wshS)
        ' Fill first row
        wshT.Cells(1, 1) = "Project Name"
        wshT.Cells(1, 2) = "Event Name"
        wshT.Cells(1, 3) = "Event Start"
        wshT.Cells(1, 4) = "Event End"
        ' Format columns C and D as date
        wshT.Range("C:D").NumberFormat = "m/d/yyyy"
        ' Row to start copying
        lngRowT = 2
        ' Loop through rows of source sheet
        For lngRow = lngFirstRow + 1 To lngLastRow
            ' Loop through columns of source sheet
            For lngCol = lngFirstCol + 2 To lngLastCol
                ' Check for date
                If IsDate(wshS.Cells(lngRow, lngCol).Value) Then
                    ' Copy project name to column A
                    wshT.Cells(lngRowT, 1).Value = wshS.Cells(lngRow, lngFirstCol).Value
                    ' Copy event name to column B
                    wshT.Cells(lngRowT, 2).Value = wshS.Cells(lngFirstRow, lngCol).Value
                    ' Copy event start to column C
                    wshT.Cells(lngRowT, 3).Value = wshS.Cells(lngRow, lngFirstCol + 1).Value
                    ' Copy event end to column D
                    wshT.Cells(lngRowT, 4).Value = wshS.Cells(lngRow, lngCol).Value
                    ' Increase target row
                    lngRowT = lngRowT + 1
                End If
            Next lngCol
        Next lngRow
        ' Autofit columns
        wshT.Range("A1:D1").EntireColumn.AutoFit
        ' Update screen again
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar

    • Marked as answer by Jim Shorts Thursday, July 25, 2013 1:22 PM
    Thursday, July 25, 2013 5:37 AM
  • Perfect! Thanks for all your help, Hans!  Do you happen to have a solid resource you would recommend for someone who is interested in learning how to code macros but doesn't have prior knowledge?
    Thursday, July 25, 2013 1:23 PM
  • Try one of John Walkenbach's books (the For Dummies ones are best suited to beginners - don't be put off by the name).

    Regards, Hans Vogelaar

    Thursday, July 25, 2013 2:28 PM
  • hello, I need to do the adverse, how can I proceed?
    Thursday, September 12, 2013 7:30 PM
  • You'll have to modify the code to suit your needs, but here is the inverse of the macro in my first reply:

    Sub Transform()
        Const lngFirstRow = 1 ' First used row
        Const lngFirstCol = 1 ' First used column
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngRowT As Long
        Dim lngColT As Long
        Dim lngLastColT As Long
        ' Do not update screen
        Application.ScreenUpdating = False
        ' Reference to active sheet
        Set wshS = ActiveSheet
        ' Last used row
        lngLastRow = wshS.Cells(lngFirstRow + 1, _
            lngFirstCol).End(xlDown).Row
        ' Create new sheet
        Set wshT = Worksheets.Add(After:=wshS)
        ' Initialize target row
        lngRowT = 1
        ' Loop through rows of source sheet
        For lngRow = lngFirstRow + 1 To lngLastRow
            ' Same project as previous row?
            If wshS.Cells(lngRow, lngFirstCol).Value <> _
                    wshS.Cells(lngRow - 1, lngFirstCol).Value Then
                ' Move to new target row
                lngRowT = lngRowT + 1
                ' Copy project name
                wshT.Cells(lngRowT, 1).Value = _
                    wshS.Cells(lngRow, lngFirstCol).Value
                ' Initialize target column
                lngColT = 1
            End If
            ' Next target column
            lngColT = lngColT + 1
            ' Copy date to column
            wshT.Cells(lngRowT, lngColT).Value = _
                wshS.Cells(lngRow, lngFirstCol + 1).Value
        Next lngRow
        ' Determine last target column
        lngLastColT = wshT.Cells.Find(What:="*", _
            SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        ' Fill first row
        wshT.Cells(1, 1).Value = "Project"
        For lngColT = 2 To lngLastColT
            wshT.Cells(1, lngColT).Value = "Date " & (lngColT - 1)
        Next lngColT
        ' Set date format
        wshT.Range(wshT.Cells(2, 2), wshT.Cells(lngRowT, lngLastColT)) _
            .NumberFormat = "m/d/yyyy"
        ' Autofit columns
        wshT.Range(wshT.Cells(1, 1), wshT.Cells(1, lngLastColT)) _
            .EntireColumn.AutoFit
        ' Update screen again
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Proposed as answer by pjscho Tuesday, October 08, 2013 10:58 AM
    Thursday, September 12, 2013 8:13 PM
  • Hi Hans,

     

    I have tried to adapt the above, really useful, macro to help solve a challenge which I have, along the same lines as Jim above.

    But I need to transpose an excel spreadsheet as described below - where the top array of cells is transposed to the bottom format.

     

    Project A 23/02/12 25/06/13
    Project A 10/06/13 18/09/13
    Project A 17/06/13 31/10/13
    Project A 12/11/13 12/11/13
    Project A 23/08/13 23/08/13
    Project A 20/05/13 04/09/13
    Project B 19/10/12 26/12/13
    Project B 28/06/13 23/01/14
    Project B 19/09/13 31/01/14
    Project B 03/02/14 01/09/14
    Project B 31/03/14 31/03/14
    Project B 01/09/14 01/09/14
    Project C 24/06/15 24/06/15
    Project C 01/11/12 06/11/12
    Project C 01/11/12 30/09/13
    Project C 01/11/12 14/02/14
    Project C 02/09/13 02/09/13
    Project C 10/02/14 10/02/14
    Project D 10/02/14 10/02/14
    Project D 10/02/14 07/03/14
    Project D 10/03/14 04/04/14
    Project D 10/02/14 10/02/14
    Project D 10/02/14 10/02/14
    Project D 10/03/14 04/04/14

    Project Start Finish Start Finish Start Finish Start Finish Start Finish Start Finish
    Project A 23/02/12 25/06/13 10/06/13 18/09/13 17/06/13 31/10/13 12/11/13 12/11/13 23/08/13 23/08/13 20/05/13 04/09/13
    Project B 19/10/12 26/12/13 28/06/13 23/01/14 19/09/13 31/01/14 03/02/14 01/09/14 31/03/14 31/03/14 01/09/14 01/09/14
    Project C 24/06/15 24/06/15 01/11/12 06/11/12 01/11/12 30/09/13 01/11/12 14/02/14 02/09/13 02/09/13 10/02/14 10/02/14
    Project D 10/02/14 10/02/14 10/02/14 07/03/14 10/03/14 04/04/14 10/02/14 10/02/14 10/02/14 10/02/14 10/03/14 04/04/14

    You will be making a tired project manager very happy if you could point the way forwards as to how I can

    modify your macro to achieve my desired results.

    Tuesday, October 08, 2013 11:34 AM
  • The following macro should do what you want. It assumes that the first row in your source data contains headers or is blank, and that the actual data start on the second row.

    Sub Transform()
        Const lngFirstRow = 1 ' First used row
        Const lngFirstCol = 1 ' First used column
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim lngRow As Long
        Dim lngLastRow As Long
        Dim lngRowT As Long
        Dim lngColT As Long
        Dim lngLastColT As Long
        ' Do not update screen
        Application.ScreenUpdating = False
        ' Reference to active sheet
        Set wshS = ActiveSheet
        ' Last used row
        lngLastRow = wshS.Cells(lngFirstRow + 1, _
            lngFirstCol).End(xlDown).Row
        ' Create new sheet
        Set wshT = Worksheets.Add(After:=wshS)
        ' Initialize target row
        lngRowT = 1
        ' Loop through rows of source sheet
        For lngRow = lngFirstRow + 1 To lngLastRow
            ' Same project as previous row?
            If wshS.Cells(lngRow, lngFirstCol).Value <> _
                    wshS.Cells(lngRow - 1, lngFirstCol).Value Then
                ' Move to new target row
                lngRowT = lngRowT + 1
                ' Copy project name
                wshT.Cells(lngRowT, 1).Value = _
                    wshS.Cells(lngRow, lngFirstCol).Value
                ' Initialize target column
                lngColT = 1
            End If
            ' Next target column
            lngColT = lngColT + 1
            ' Copy start date to column
            wshT.Cells(lngRowT, lngColT).Value = _
                wshS.Cells(lngRow, lngFirstCol + 1).Value
            ' Next target column
            lngColT = lngColT + 1
            ' Copy finish date to column
            wshT.Cells(lngRowT, lngColT).Value = _
                wshS.Cells(lngRow, lngFirstCol + 2).Value
        Next lngRow
        ' Determine last target column
        lngLastColT = wshT.Cells.Find(What:="*", _
            SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious).Column
        ' Fill first row
        wshT.Cells(1, 1).Value = "Project"
        For lngColT = 2 To lngLastColT Step 2
            wshT.Cells(1, lngColT).Value = "Start"
            wshT.Cells(1, lngColT + 1).Value = "Finish"
        Next lngColT
        ' Set date format
        wshT.Range(wshT.Cells(2, 2), wshT.Cells(lngRowT, lngLastColT)) _
            .NumberFormat = "m/d/yyyy"
        ' Autofit columns
        wshT.Range(wshT.Cells(1, 1), wshT.Cells(1, lngLastColT)) _
            .EntireColumn.AutoFit
        ' Update screen again
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, October 08, 2013 10:58 PM