Convert multiple contiguous columns as one single column maintaining their(rows and columns) order using VBA

   

Dim wb As Workbook

 Set wb = ActiveWorkbook

 Dim wf As Worksheet


With wb
    For Each oSheet In .Sheets

        If oSheet.Name = "verticalmm" Then
            oSheet.Delete
            
          
            
            
            
            

        End If
Next oSheet
    Set wf = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    wf.Name = "verticalmm"
    End With
    
    
' wb.Close savechanges:=True
   
   
    Dim Range1 As Range, Range2 As Range, Rng As Range
    Dim rowIndex As Integer
    we.Select
    
    Range("B2").Select
    If ActiveCell.Offset(1, 0).Value <> "" Then
    
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Else
    Exit Sub
    End If
    
   Set Range1 = Application.Selection
   'Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
     'Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
     Set Range2 = wf.Range("A1")
     'we.Select
     For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False
wf.Select

Dim last_row As Long

    last_row = Cells(Rows.Count, 1).End(xlUp).Row
    'MsgBox (last_row)
    
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "0"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A1:A2").Select
    Selection.AutoFill Destination:=Range("A1:A" & last_row)
    
   
   wb.Close savechanges:=True

 

 

Source:https://www.extendoffice.com/documents/excel/1172-excel-transpose-multiple-columns-into-one-column.html