Excel sayıda sütun alıp iki sütun

Question

Şöyle verilere sahip onları yığın ...

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

Ve bu çevirmek için VBA bir senaryo yazmak istiyorum ister ... diğer bir deyişle,

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

, her iki sütun iki yeni sütun halinde dizilir.
Aşağıdaki kod tek sütunlar için çalışıyor ... İki işe mi çalışacağım? Örneğin, her bir harfli sütun için bir kez, sonra her numaralı sütun için bir kez daha iki kez çalıştırmanın bir yolu var mı? Ya da belki de daha temiz bir yol?

verilere Sayfa1 ile

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` 

Answer 1

, bu 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 

bu üretecek:

Sayfa2'deiçinde.

Answer 2

Gelecekte görüntüleyenler için bu komutu iki kez çalıştırmayı bitirdim. Sonra

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 

:

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