2016-03-24 204 views
0

我有一个看起来像这样的数据...希望Excel采取多列,并将它们堆叠成两列

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

而且我想在VBA编写一个脚本把它变成这样...

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

换句话说,每两列将被堆叠成两个新列。
以下代码适用于单列...我如何才能使它工作两个? 例如,是否有一种方法可以为每个字母列运行两次...一次,然后再为每个编号列运行一次?或者可能完全干净?

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` 

回答

1

随着Sheet 1中数据,这个宏:

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 

会产生这样的:

enter image description here

Sheet 2中

+0

谢谢。但是,如果有两行以上的话呢? – user2192778

+0

这将是对代码..........的简单更改,但您需要定义准确的映射................当前代码实际传输从一张纸到另一张的** 4 **细胞块。 –

0

对于未来的观众,我结束了两次运行这个命令。

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