Chcete Excel, aby sa veľa stĺpcov a zásobník je do dvoch stĺpcov - Excel, VBA, Excel-VBA

Mám údaje, ktoré vyzerajú takto ...

a    1    c    3    e    5
b    2    d    4    f    6

A ja by som chcel napísať scenár vo VBA, aby som to zmenil ...

a    1
b    2
c    3
d    4
e    5
f    6

Inými slovami, každé dva stĺpce budú naskladané do dvoch nových stĺpcov.
Nasledujúci kód funguje pre jednotlivé stĺpce ... Ako ju dostanem do práce pre dvoch? Existuje napríklad spôsob, ako to spustiť dvakrát ... raz pre každý napísaný stĺpec, potom opäť pre každý očíslovaný stĺpec? Alebo možno celkom čistejšie?

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`

odpovede:

S údajmi v Sheet1, toto makro:

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

bude to produkovať:

v Sheet2.

Pre budúcich divákov som skončil s týmto príkazom dvakrát.

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

potom:

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