創建一個行堆棧算法

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