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

变为

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

祝你好运。

只是一个FYI，这就是你想要改变原始宏的方式：

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

创建行堆叠算法

1 个答案: