Macro for changing structure of data in Excel

I have a spreadsheet that contains extracted data from another source, and I need to change the structure of the data to a more usable format for output to a pivot table. As I will be receiving the data in this format on a regular basis and need to perform this restructuring task every time, I would like to automate this task with a macro.

Spreadsheet description:
Each WO task has same 5 column headings: WO#, WO_Type, Date, Min, and Min_Type, and the WO numbers are repeated in each 5-column section across the spreadsheet:
Column A to E: WO task 1
Column F to J: WO task 2
Column K to O: WO task 3
Column P to T: WO task 4

While the current spreadsheet has 455 rows, the number of rows will vary each time.

I would like a macro that does the following:
  • Copies data from A2 to E2 and down to last row containing data, and pastes this data into B2 of table in "Tasks" tab.
  • Copies data from F2 to J2 down to last row containing data, and pastes this date into next available blank row in Column B of table in "Tasks" tab
  • Copies data from K2 to O2 down to last row containing data, and pastes this date into next available blank row in Column B of table in "Tasks" tab
  • Copies data from P2 to T2 down to last row containing data, and pastes this date into next available blank row in Column B of table in "Tasks" tab

I have attached the spreadsheet with sample data.

Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
I think this does what you want, please check and let me know if it needs any revision.

Note I have removed all the unused rows in the destination table as this makes it extremely difficult to calculate where to paste the data. I have replaced CFS with ="CFS" to ensure this is copied down as data is added.
AndreamaryAuthor Commented:
Hi Roy,

Thanks very much for improving the process as outlined. I ran the macro, and it transferred all the records from Column A to E (WO task 1), which was good, but it did not appear to transfer the remaining records for WO task 2 (Column F to J), etc. through to WO task 4. Sheet 1 should end up with 1816 rows of data, I believe.

Can the macro be revised to do this?

ShumsExcel & VBA ExpertCommented:
Hi Andrea,

Try attached...

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Roy CoxGroup Finance ManagerCommented:
Hi Andrea


I've adjusted the code. Try this

Option Explicit

Sub TransferData()
    Dim oTblSource As ListObject, oTblMain As ListObject
    Dim iX As Integer
    Dim lRw As Long
    Set oTblSource = Sheets("Sheet1").ListObjects(1)
    Set oTblMain = Sheets("Tasks").ListObjects(1)

    With oTblMain
        For iX = 1 To oTblSource.ListColumns.Count Step 5    '
            lRw = .ListRows.Count + 1
            oTblSource.ListColumns(iX).DataBodyRange.Resize(, 5).Copy
            oTblMain.ListRows(1).Range.Cells(lRw, 2).PasteSpecial xlValues
        Next iX
    End With
    Application.CutCopyMode = False
End Sub

Open in new window

AndreamaryAuthor Commented:
Thanks to you both!

Roy, thanks for the revised macro, it worked well with a couple of minor issues - the first row was blank, for some reason, and the date field came in numerically as opposed to formatted as a date.

Shums, your solution worked perfectly.

I did my best to award the points fairly, balancing Roy's quick response time and willingness to revise the first iteration vs. Shum's solution working right out of the gate. :-)

Best regards,
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.