Transpose multiple rows, varied length, to a single column?

Hello, I would like to transpose multiple rows, varied length, to a single column. There are various worksheets and each sheet has a different number of rows. Each rows have a different number of used cells. Each sheet has data starting in Column B. I would like to be able to transpose all rows to a Column A.


For example Sheet 1 has -

R1A1	R1A2	R1A3	R1A4	R1A5
R2A1	R2A2	R2A3	R2A4
R3A1	R3A2	R3A3	R3A4	R3A5	R3A6	R3A7	R3A8

Desired result -

R1A1

R1A2

R1A3

R1A4

R1A5

R2A1

R2A2

R2A3

R2A4

R3A1

R3A2

R3A3

R3A4

R3A5

R3A6

R3A7

R3A8

The macro that I have found that can do this uses the same range for each row and therefore it pastes empty cells. I have hundreds of row in each sheet making the removal of the empty cells time consuming.

Thanks in advance for any help or tips

assuming all sheets in the workbook will be processed, and there are no blank cells in Col B, try this

Code:

---

Sub vbax_62930_merge_multi_rows_in_mono_col()

    Dim w As Long, r As Long, c As Long
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    For w = 1 To Worksheets.Count
        With Worksheets(w)
            For r = 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
                For c = 2 To .Cells(r, .Columns.Count).End(xlToLeft).Column
                    .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = .Cells(r, c).Value
                Next c
            Next r
        End With
    Next w

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

---

Quote:

---

Originally Posted by mancubus

assuming all sheets in the workbook will be processed, and there are no blank cells in Col B, try this

---

Thank you. That was perfect. It works very fast and it's far better than the macro I found elsewhere.

If I wanted to use it on a single worksheet in a workbook with multiple worksheets what needs to be changed?

you are welvome

please do not quote the whole messages. just refer to the related bit(s) where necessary.

Code:

---

Sub vbax_62930_merge_multi_rows_in_mono_col()

    Dim w As Long, r As Long, c As Long
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    With Workbooks("MyOpenworkbookNameHere").Worksheets("MyDesiredWorksheetNameHere")
        For r = 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
            For c = 2 To .Cells(r, .Columns.Count).End(xlToLeft).Column
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = .Cells(r, c).Value
            Next c
        Next r
    End With

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

---

PS:
Workbooks("MyOpenworkbookNameHere").Worksheets("MyDesiredWorksheetNameHere" ) => refers to a specific open workbook
ActiveWorkbook.Worksheets("MyDesiredWorksheetNameHere") => refers to the active workbook in the window
ThisWorkbook.Worksheets("MyDesiredWorksheetNameHere") => refers to the workbook that contains the macro(s).

Quote:

---

Originally Posted by mancubus

you are welvome

PS:
Workbooks("MyOpenworkbookNameHere").Worksheets("MyDesiredWorksheetNameHere" ) => refers to a specific open workbook
ActiveWorkbook.Worksheets("MyDesiredWorksheetNameHere") => refers to the active workbook in the window
ThisWorkbook.Worksheets("MyDesiredWorksheetNameHere") => refers to the workbook that contains the macro(s).

---

Thank you. That helped me out a lot. Since I go to the worksheet before running the script I just tried With ActiveSheet which worked fine.

Or with a little less looping. Might be slightly faster yet on a larger file.

Code:

---

Sub Try()
Dim i As Long, ii As Long
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
    ii = Cells(i, Columns.Count).End(xlToLeft).Column
        Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(ii - 1).Value = Application.Transpose(Range(Cells(i, 2), Cells(i, ii)).Value)
Next i
Application.ScreenUpdating = True
End Sub

---