Excel macro to move columns to 1 row after each other

[brubakes]

I was hoping someone could help me write or find a macro that would take two columns and move it to column A under the previous data and repeat for all columns. Basically user information is located in pairs of columns (typeofvalue, value). So column A and B are for user1, column C and D are user2, column E and F are user3, etc. Bonus if I could have a space in between each once moved.

Current:

[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]User1First[/TD]
[TD]User1Last[/TD]
[TD]User2First[/TD]
[TD]User2Last[/TD]
[/TR]
[TR]
[TD]User1ValueTypeA1[/TD]
[TD]User1ValueB1[/TD]
[TD]User2ValueTypeA1[/TD]
[TD]User2ValueB1[/TD]
[/TR]
[TR]
[TD]User1ValueTypeA2[/TD]
[TD]User1ValueB2[/TD]
[TD]User2ValueTypeA1[/TD]
[TD]User2ValueB1[/TD]
[/TR]
</tbody>[/TABLE]

Desired:

[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]User1First[/TD]
[TD]User1Last[/TD]
[/TR]
[TR]
[TD]User1ValueTypeA1[/TD]
[TD]User1ValueB1[/TD]
[/TR]
[TR]
[TD]User1ValueTypeA2[/TD]
[TD]User1ValueB2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]User2First[/TD]
[TD]User2Last[/TD]
[/TR]
[TR]
[TD]User2ValueTypeA1[/TD]
[TD]User2ValueB1[/TD]
[/TR]
[TR]
[TD]User2ValueTypeA1[/TD]
[TD]User2ValueB1[/TD]
[/TR]
</tbody>[/TABLE]



Each user has 47 rows of "values", for the example I just did two rows worth.

 

[mumps]

Try:

Sub MoveCols()
    Application.ScreenUpdating = False
    Dim lColumn As Long
    lColumn = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
    Dim x As Long, y As Long
    For x = 1 To lColumn Step 2
        Range(Cells(1, x), Cells(Range("A" & Rows.Count).End(xlUp).Row, x)).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(2, 0)
    Next x
    For y = 2 To lColumn Step 2
        Range(Cells(1, y), Cells(Range("A" & Rows.Count).End(xlUp).Row, y)).Copy Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(2, 0)
    Next y
    If Sheets("Sheet2").Range("A1") = "" Then
        Sheets("Sheet2").Range("1:2").EntireRow.Delete
    End If
    Application.ScreenUpdating = True
End Sub

 

[brubakes]

Try:

Sub MoveCols()
    Application.ScreenUpdating = False
    Dim lColumn As Long
    lColumn = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
    Dim x As Long, y As Long
    For x = 1 To lColumn Step 2
        Range(Cells(1, x), Cells(Range("A" & Rows.Count).End(xlUp).Row, x)).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(2, 0)
    Next x
    For y = 2 To lColumn Step 2
        Range(Cells(1, y), Cells(Range("A" & Rows.Count).End(xlUp).Row, y)).Copy Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(2, 0)
    Next y
    If Sheets("Sheet2").Range("A1") = "" Then
        Sheets("Sheet2").Range("1:2").EntireRow.Delete
    End If
    Application.ScreenUpdating = True
End Sub

Looks to be good, exactly what I was trying to do. Thank you!

 

[mumps]

My pleasure.