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
