excel - 创建行堆叠算法

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