user2192778
user2192778

Reputation: 455

Want Excel to take many columns and stack them into two columns

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

Answers (2)

user2192778
user2192778

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

Gary's Student
Gary's Student

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:

enter image description here

in Sheet2.

Upvotes: 1

Related Questions