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

[Commoner]

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

[mancubus]

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



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

[Commoner]

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?

[mancubus]

you are welvome

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



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).

[Commoner]

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.

[jolivanes]

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

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