macro to move columns

[fenrost]

Hi,
Is there anyone who could help me with one macro? This is the format of the data:

And this is what I would like to have at the end:

So basically I need a macro that would copy column D&E and put the data below B&C, also copying tasks respectively. and then the same for all other columns. The problem is that the number of columns varies... sometimes it's 30, sometimes it's much more.

 

[fenrost]

OK, I copied the data to a new excel spreadsheet and it works. Probably there was something in the old file.

Thanks so much for your help!!!!

 

[btadams]

This may work better but will require you to select the table before running the macro:

Sub Stack2()
Dim rngMyRng As Range, lngCols As Long, i As Long, j As Long


    
    ' Count number of iterations needed
    lngCols = Application.WorksheetFunction.RoundDown((Selection.Columns.Count - 3) / 2, 0)
    Set rngMyRng = Selection.Cells(2, 1)
    ' Count number of tasks in column A
    j = Range(rngMyRng, rngMyRng.End(xlDown)).Cells.Count
    
    ' Stack columns
    For i = 1 To lngCols
        Range(rngMyRng, rngMyRng.Offset(j - 1, 0)).Copy Destination:=rngMyRng.End(xlDown).Offset(1, 0)
        Range(rngMyRng.Offset(0, 2 * (i - 1) + 3), rngMyRng.Offset(j, 2 * (i - 1) + 4)).Copy Destination:=rngMyRng.Offset(j * i, 1)
    Next i
    
    ' Clear copied cells
    Range(rngMyRng.Offset(-1, 3), rngMyRng.Offset(j - 1, Selection.Columns.Count - 1)).Clear

End Sub

 

[fenrost]

This is even better. And if I also want to delete blank rows at the end of the script, what should I add to the code?