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:

A	B	C	D
User1First	User1Last	User2First	User2Last
User1ValueTypeA1	User1ValueB1	User2ValueTypeA1	User2ValueB1
User1ValueTypeA2	User1ValueB2	User2ValueTypeA1	User2ValueB1

<tbody>
</tbody>

Desired:

A	B
User1First	User1Last
User1ValueTypeA1	User1ValueB1
User1ValueTypeA2	User1ValueB2
User2First	User2Last
User2ValueTypeA1	User2ValueB1
User2ValueTypeA1	User2ValueB1

<tbody>
</tbody>

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.