excel - 行スタッキング アルゴリズムの作成

Question

n列を取り、それらを積み重ねて1つの巨大な列を作成するExcel用のvbaスクリプトがあります。行を読み取り、代わりに転置をスタックするように変更する最も効率的な方法は何ですか? 私のコードは以下の通りです：

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

ここに2つのサブがあります。列を積み重ねるもの - 行を積み重ねるもの - 入力データはあなたの選択です。それらを試して、違いを見てください。

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

もう1つは次のとおりです。

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