Move all columns to single row using Excel VBA

Question

Data which I have is like this

23  | 34    | 56    | 75    | 23    
56  | 34    | 56    | 23    | 12    
12  | 34    | 56    | 78    | 12

I want to convert this to all in single column

23    
34    
56    
75    
23   
56    
34    
56  
23    
12    
12    
34    
56    
78    
12

The code which I currently use is below,

Sub ReArrangeCols()
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Selection.End(xlUp).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Selection.End(xlUp).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Selection.End(xlUp).Select
    Selection.End(xlToRight).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Selection.End(xlToLeft).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    Selection.End(xlUp).Select
End Sub

• Q1 - Run time: 3-4 seconds. How can it be optimised?

• Q2 - The code only runs correctly if the cell selected is the first cell i.e. 23 in our above example. How can I make the cursor / Selction go automatically to the first cell so that the code will work even if the user has selected some other cell.

Answer 1

Try this:

Private Sub Test()
Dim src As Range
Dim out() As String
Dim I As Integer, counter As Integer
Set src = Cells(1, 1).CurrentRegion
counter = src.Cells.Count
ReDim out(1 To counter)
    For I = 1 To src.Cells.Count
        out(I) = src.Cells(I).Value
    Next

    src.ClearContents
    Cells(1, 1).Resize(counter, 1).Value = Application.WorksheetFunction.Transpose(out)
End Sub

Answer 2

Try the below code:

Sub RangetoColumn()
    Dim LastRow As Long, LastColumn As Long
    Dim CurrentSheet As Worksheet, TargetSheet As Worksheet
    Dim i As Long, j As Long, Count As Long

    Set CurrentSheet = ThisWorkbook.Worksheets("Sheet1")
    Set TargetSheet = ThisWorkbook.Worksheets("Sheet2")
    LastRow = CurrentSheet.Cells(Rows.Count, "A").End(xlUp).Row

    Count = 1
    For i = 1 To LastRow
        LastColumn = CurrentSheet.Cells(i, Columns.Count).End(xlToLeft).Column
        For j = 1 To LastColumn
            TargetSheet.Range("A" & Count).Value = CurrentSheet.Cells(i, j).Value
            Count = Count + 1
        Next j
    Next i
End Sub

Assumptions:
1. data is in Sheet1 and result will be pasted in Sheet2.
2. data starts from Cell A1