Creating a Row-Stacking Algorithm

Question

I have a vba script for Excel that takes n columns and stacks them, one on top of the other, to create one giant column. What's the most efficient way to modify it so that it reads rows and stacks their transpose instead? My code is below:

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

As an example:

Example:

12345  
67899

becomes

Don't have time to answer properly, but I would suggest that you use the Copy/Paste Special: Transpose feature, as it's probably easier to read and code than to adjust this to stack rows. If you did adjust this to stack rows, you would probably need to adjust the offset appropriately. — Joe
– Joe, Commented Jul 18, 2013 at 15:51

Stepan1010 · Accepted Answer · 2013-07-18 16:03:19Z

Here are two subs. One that stacks columns - one that stacks rows - the input data is your selection. Try them out and look at the differences:

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

Here is the other one:

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

Good Luck.

And just an FYI, this is how you would want to alter your original macro:

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

Collectives™ on Stack Overflow

Creating a Row-Stacking Algorithm

1 Answer 1

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Your Answer

Sign up or log in

Post as a guest

Related