创build行堆栈algorithm

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

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

这里有两个潜艇。 一个堆栈列 – 一个堆栈行 – input数据是您的select。 尝试一下，看看不同之处：

 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 

祝你好运。

而只是一个FYI，这是你想要改变你的原始macros：

 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