Move Columns to Rows in Excel

LRI1
LRI1 used Ask the Experts™
on
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
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solution Only
Badotz
Top Expert 2007

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

Author

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

Commented:
How long does the Transpose function take to run?
Top Expert 2010
Commented:
LRI1,

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)
        Next
    Next
    
    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


Patrick
LRI1

Author

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