创建一个行堆栈算法

Question

我有一个Excel的vba脚本，需要n列并将它们堆叠起来，一个在另一个之上，以创建一个巨型列。什么是最有效的方式来修改它，以便它读取行并堆叠它们的转置？我的代码如下：

Sub Data_to_Column() 
Dim rData As Range 
Dim r As Range, c As Range 
Dim rStart As Range 
Dim counter As Integer 

Set rData = Selection 
On Error Resume Next 

Application.DisplayAlerts = False 

Set rStart = Application.InputBox(_ 
Prompt:="Select the 1st cell you want to copy the data to.", _ 
Title:="Select Output Location", _ 
Type:=8) 
On Error GoTo 0 

Application.DisplayAlerts = True 

If rStart Is Nothing Then Exit Sub 
For Each c In rData.Columns 
    For Each r In rData.Rows 
    If Not IsEmpty(Cells(r.Row, c.Column)) Then 
    rStart.Offset(counter, 0) = Cells(r.Row, c.Column) 
    counter = counter + 1 
    End If 
Next r: Next c 

End Sub 

作为一个例子：

实施例：

12345 
67899 

变得

1 
2 
3 
4 
5 
6 
7 
8 
9 
9 

Answer 1

这里有两个字幕。一个堆栈列 - 一个堆栈行 - 输入数据是您的选择。尝试出来，看看它们的不同：

Sub MakeOneColumnStackColumns() 

    Dim vaCells As Variant 
    Dim vOutput() As Variant 
    Dim i As Long, j As Long 
    Dim lRow As Long 

    If TypeName(Selection) = "Range" Then 
     If Selection.Count > 1 Then 
      If Selection.Count <= Selection.Parent.Rows.Count Then 
       vaCells = Selection.Value 

       ReDim vOutput(1 To UBound(vaCells, 1) * UBound(vaCells, 2), 1 To 1) 

       For j = LBound(vaCells, 2) To UBound(vaCells, 2) 
        For i = LBound(vaCells, 1) To UBound(vaCells, 1) 
         If Len(vaCells(i, j)) > 0 Then 
          lRow = lRow + 1 
          vOutput(lRow, 1) = vaCells(i, j) 
         End If 
        Next i 
       Next j 

       Selection.ClearContents 
       Selection.Cells(1).Resize(lRow).Value = vOutput 
      End If 
     End If 
    End If 
End Sub 

这里是另一个：

Sub MakeOneColumnStackRows() 

    Dim vaCells As Variant 
    Dim vOutput() As Variant 
    Dim i As Long, j As Long 
    Dim lRow As Long 

    If TypeName(Selection) = "Range" Then 
     If Selection.Count > 1 Then 
      If Selection.Count <= Selection.Parent.Rows.Count Then 
       vaCells = Selection.Value 

       ReDim vOutput(1 To UBound(vaCells, 1) * UBound(vaCells, 2), 1 To 1) 

       For j = LBound(vaCells, 1) To UBound(vaCells, 1) 
        For i = LBound(vaCells, 2) To UBound(vaCells, 2) 
         If Len(vaCells(j, i)) > 0 Then 
          lRow = lRow + 1 
          vOutput(lRow, 1) = vaCells(j, i) 
         End If 
        Next i 
       Next j 

       Selection.ClearContents 
       Selection.Cells(1).Resize(lRow).Value = vOutput 
      End If 
     End If 
    End If 

End Sub 

好运。

而只是一个供参考，这是你将要如何改变你原来的宏：

Sub Data_to_Column() 
Dim rData As Range 
Dim r As Range, c As Range 
Dim rStart As Range 
Dim counter As Integer 

Set rData = Selection 
On Error Resume Next 

Application.DisplayAlerts = False 

Set rStart = Application.InputBox(_ 
Prompt:="Select the 1st cell you want to copy the data to.", _ 
Title:="Select Output Location", _ 
Type:=8) 
On Error GoTo 0 

Application.DisplayAlerts = True 

If rStart Is Nothing Then Exit Sub 
For Each r In rData.Rows 
    For Each c In rData.Columns 
    If Not IsEmpty(Cells(r.Row, c.Column)) Then 
    rStart.Offset(counter, 0) = Cells(r.Row, c.Column) 
    counter = counter + 1 
    End If 
Next c: Next r 

End Sub