Creating a String Gating 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 is the most efficient way to change it so that it reads the lines and instead transposes them? 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

 1 2 3 4 5 6 7 8 9 9 

Answer 1

Here are two subsets. The one that contains the columns - the one that stacks the rows - the input is your choice. 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 another 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 only FYI, this is how you want to change the 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