Move Columns to Rows in Excel

LRI1 used Ask the Experts™
I have a rather large spreadsheet of data that I need to export as a CSV file so I can import into a database.  My issue is the data is populated horizontally based on the key field (employee ID).  What I would like to do it take the data and move it vertically so the CSV file will be in the format I need.  Copy and paste special - transpose will work, however this spreadsheet is huge and will take a lot of time to transpose.  I also thought about using MS Query and or Crystal Reports to get my data in the correct format.  Any idea's how I could accomplish this task?  Possibly with an option I outlined above or some programming or formula?  I have included a small screen shot of what the layout currently is and what I am looking to achieve.  Thank you.

Screen shot example
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2007

If this is a one-time thing, let Transpose do its job - does it really matter how long it takes?


When there are over 350 employees and 250 columns - yes it really does matter.  This may not be a "one time thing".
Top Expert 2007

How long does the Transpose function take to run?
Top Expert 2010

The following seems to work for me.  Modify the location you want it saved to in the end.

The sub automatically finds the last row and last column.

Sub ExportToCSV()
    Dim arr As Variant
    Dim LastR As Long, LastC As Long
    Dim DestWb As Workbook
    Dim DestWs As Worksheet
    Dim r As Long, c As Long
    Dim DestR As Long
    Dim DestArr() As Variant
    Dim LastName As String
    Dim EmpNum As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    With ActiveSheet
        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range("a1", .Cells(LastR, LastC)).Value
    End With
    ReDim DestArr(1 To (LastR - 1) * (LastC - 2), 1 To 4) As Variant
    For r = 2 To UBound(arr, 1)
        LastName = arr(r, 1)
        EmpNum = arr(r, 2)
        For c = 3 To UBound(arr, 2)
            DestR = DestR + 1
            DestArr(DestR, 1) = LastName
            DestArr(DestR, 2) = EmpNum
            DestArr(DestR, 3) = arr(1, c)
            DestArr(DestR, 4) = arr(r, c)
    Set DestWb = Workbooks.Add
    Set DestWs = DestWb.Worksheets(1)
    With DestWs
        .[a1].Resize(DestR, 4).Value = DestArr
        .[d:d].NumberFormat = "mm/dd/yyyy"
    End With
    With DestWb
        .SaveAs "c:\foo.csv", xlCSV
        .Close False
    End With
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    MsgBox "Done"
End Sub

Open in new window



Perfect!  Just what I needed.  Thanks Patrick!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial