Stack multiple columns into two colums in pairs of two

[navelgazer]

<table><tbody><tr><td class="votecell">
</td> <td class="postcell"> I'm new to excel and VBA and I'm stuck at this problem. I have columns A through AKP (A:AKP) with data, and there is a varied number of rows for each column. If possible, I need a macro that will "stack" columns in pairs of two. For example, column "C" directly under column "A" and column "D" directly under column "B" and so on for all columns A:AKP.



This is an example of what my data looks like:


<code> COLUMN A COLUMN B COLUMN C COLUMN D
ROW 1 2598 F800 2599 F800
ROW 2 2598 K1300 2599 K1300
ROW 3 2598 S1000RR 2599 R900
ROW 4 2598 G650 2599 G650
ROW 5 2598 R1200 2599 K1600
ROW 6 2599 S1000
ROW 7 2599 HP2
ROW 8 2599 R1200
.
.
.
</code>
This is an example of what I need the output to look like:

<code> COLUMN A COLUMN B
ROW 1 2598 F800
ROW 2 2598 K1300
ROW 3 2598 S1000RR
ROW 4 2598 G650
ROW 5 2598 R1200
ROW 6 2599 S1000
ROW 7 2599 HP2
ROW 8 2599 R1200
ROW 9 2599 F800
ROW 10 2599 K1300
ROW 11 2599 R900
ROW 12 2599 G650
ROW 13 2599 K1600
.
.
.

Thank you in advance!
</code>

</td></tr></tbody></table>

 

[Tom Urtis]

Try this on a copy of your worksheet:

Sub Test1()
Application.ScreenUpdating = False
Dim xColumn&, LastRow&, NextRow&
For xColumn = 3 To 977 Step 2
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
LastRow = Cells(Rows.Count, xColumn).End(xlUp).Row
Range(Cells(1, xColumn), Cells(LastRow, xColumn + 1)).Cut Cells(NextRow, 1)
Next xColumn
Application.ScreenUpdating = True
End Sub

 

[repairman615]

Hello,




<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> TestMeOnACopy()<br>Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> Ws <SPAN style="color:#00007F">As</SPAN> Worksheet: <SPAN style="color:#00007F">Set</SPAN> Ws = ActiveSheet<br><SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> lastRow <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    j = 1<br>    <SPAN style="color:#00007F">For</SPAN> i = 3 <SPAN style="color:#00007F">To</SPAN> 978<br>        lastRow = Ws.Cells(1, i).End(xlDown).Offset(1, 0).Row<br>        <SPAN style="color:#00007F">If</SPAN> j = 3 <SPAN style="color:#00007F">Then</SPAN> j = 1<br>        Ws.Cells(1, i).Resize(lastRow, 1).Copy Destination:= _<br>                Cells(1, j).End(xlDown).Offset(1, 0)<br>        j = j + 1<br>    <SPAN style="color:#00007F">Next</SPAN> i<br><SPAN style="color:#007F00">'''ws.Range("C:AKP").Delete</SPAN><br><SPAN style="color:#00007F">Set</SPAN> Ws = <SPAN style="color:#00007F">Nothing</SPAN><br>Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[navelgazer]

Thanks guys. I went with yours, repairman. It worked great! Such a help.