Reputation: 455
I have data that looks like this...
a 1 c 3 e 5
b 2 d 4 f 6
And I would like to write a script in VBA to turn it into this...
a 1
b 2
c 3
d 4
e 5
f 6
In other words, every two columns will be stacked into two new columns.
The following code works for single columns... How do I get it to work for two?
For example, is there a way to run this twice... once for every lettered column, then again for every numbered column? Or perhaps a cleaner way altogether?
Sub StackColumns()
Dim X As Long, LastColumn As Long
LastColumn = Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column
For X = 1 To LastColumn
Columns(X).Resize(Cells(Rows.Count, X).End(xlUp).Row).Copy _
Cells(Rows.Count, LastColumn + 1).End(xlUp).Offset(-(X > 1))
Next
On Error Resume Next
Columns(LastColumn + 1).SpecialCells(xlBlanks).Delete xlShiftUp
End Sub`
Upvotes: 0
Views: 71
Reputation: 455
For future viewers, I ended up running this command twice.
Sub StackColumns()
Dim X As Long, LastColumn As Long
LastColumn = Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column
For X = 1 To LastColumn Step 2
Columns(X).Resize(Cells(Rows.Count, X).End(xlUp).Row).Copy _
Cells(Rows.Count, LastColumn + 1).End(xlUp).Offset(-(X > 1))
Next
On Error Resume Next
Columns(LastColumn + 1).SpecialCells(xlBlanks).Delete xlShiftUp
End Sub
Then:
Sub StackColumns()
Dim X As Long, LastColumn As Long
LastColumn = Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column
For X = 2 To LastColumn Step 2
Columns(X).Resize(Cells(Rows.Count, X).End(xlUp).Row).Copy _
Cells(Rows.Count, LastColumn + 1).End(xlUp).Offset(-(X > 1))
Next
On Error Resume Next
Columns(LastColumn + 1).SpecialCells(xlBlanks).Delete xlShiftUp
End Sub
Upvotes: 0
Reputation: 96753
With data in Sheet1, this macro:
Sub marine()
Dim N As Long, i As Long
Dim r As Range
Sheets("Sheet1").Select
N = Cells(1, Columns.Count).End(xlToLeft).Column - 1
For i = 1 To N Step 2
Set r = Cells(1, i).Resize(2, 2)
r.Copy Sheets("Sheet2").Cells(i, 1)
Next i
End Sub
will produce this:
in Sheet2.
Upvotes: 1