Thread: Data re-order Macro

Hello. I have been trying to put together a Macro to manipulate some data that I have and I don't seem to be able to get it right!

The data is as follows:

ITEM1 DATA1 DATA2 DATA3 DATA4.... DATA50
ITEM2 DATA1 DATA2 DATA3 DATA4.... DATA50
ITEM3 DATA1 DATA2 DATA3 DATA4.... DATA50
...
ITEMx DATA1 DATA2 DATA3 DATA4.... DATA50

and I need it to be in the format:

ITEM1 DATA1 DATA2 DATA3 DATA4 DATA5
ITEM1 DATA6 DATA7 DATA8 DATA9 DATA10
...
ITEM1 DATA46 DATA47 DATA48 DATA49 DATA50
ITEM2 DATA1 DATA2 DATA3 DATA4 DATA5
...
ITEMx DATA46 DATA47 DATA48 DATA49 DATA50

So in summary, for each ITEM, the first 5 data items, then on the next row the same ITEM with the next 5 data items... and so on up to the last 5 before moving onto the next ITEM.

I hope this makes sense. Thanks in advance!

The following assumes no header row on the initial sheet and that the initial sheet is active when the macro is run.
The macro creates a sheet called "Sheet_Copy" and transforms the data onto that sheet. The original sheet is untouched. It is created for variable number of columns.

Code:

Sub moveIt()
Dim i As Long, j As Long, toRow As Long
Dim lCol As Long, lRow As Long
Dim shTo As Worksheet, shFr As Worksheet
Dim strcur As String
Set shFr = ActiveSheet
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Sheet_Copy").Delete
Sheets.Add After:=shFr
ActiveSheet.Name = "Sheet_Copy"
On Error GoTo 0
Application.DisplayAlerts = True
Set shTo = ActiveSheet
shFr.Activate

lCol = shFr.Cells(1, Columns.Count).End(xlToLeft).Column
lRow = shFr.Cells(Rows.Count, 1).End(xlUp).Row
toRow = 1
For i = 1 To lRow
    j = 2

    strcur = shFr.Cells(i, 1)
    Do Until shFr.Cells(i, j) = ""
        shTo.Cells(toRow, 1) = strcur
        shFr.Range(shFr.Cells(i, j), shFr.Cells(i, j + 4)).Copy _
                Destination:=shTo.Cells(toRow, 2)
        toRow = toRow + 1
        j = j + 5
    Loop
Next
End Sub