Custom VBA Column to Row Insert and Transpose

[jisaacreese]

I am trying to cut a range of columns with data(in the serial field) and paste/transpose them into a custom inserted number of rows underneath the current row. Here is what I am starting with:
16566

And here is what I want to end with:

16567

The trick here is that I will have hundreds of populated rows with a varying quantity of serial numbers. I need a macro that will let me select the range of serial numbers in each row and CUT-paste/transpose into a created set of rows underneath. I understand how to use basic VBA for inserting a fixed number of rows, but I am stumped on how to make a dynamic number of inserted rows.

Logically, the operation seems to be:
Select and copy F2:H2-->Identify number of selected columns as 3-->Insert 3 empty rows between rows 2 and 3--> Paste F2:H2 into E3:E5, transposed-->Delete data in F2:H2

For clarity, the next operation to do the next set of values (after the above is performed) would be:
Select and copy F6:J6-->Identify number of selected columns as 5-->Insert 5 empty rows between rows 6 and 7--> Paste F6:J6 into E7:E11, transposed-->Delete data in F6:J6

With a final product of this:
16568


I need a single macro that can do this.

Help! I'm in over my head!

[jisaacreese]

Here is the VBA code I recorded to do this manually, but it won't work for any other line:


Sub transpose()
'
' transpose Macro
'


'
Range("E3:E6").Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Range("F2:H2").Select
Selection.Copy
Range("E3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, transpose:=True
Range("F2:H2").Select
Application.CutCopyMode = False
Selection.ClearContents
End Sub

[mdmackillop]

Sub test()
r = ActiveCell.Row
c = Cells(r, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(r, 5), Cells(r, c))
Cells(r + 1, 5).Resize(Rng.Cells.Count - 1).EntireRow.Insert
arr = Rng
Rng.ClearContents
Cells(r, 5).Resize(c - 4).Value = Application.Transpose(arr)
End Sub

[mdmackillop]

For multiple rows

Sub test()
Set ac = ActiveCell
For i = Selection.Cells.Count To 1 Step -1
r = ac.Offset(i - 1).Row
c = Cells(r, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(r, 5), Cells(r, c))
Cells(r + 1, 5).Resize(Rng.Cells.Count - 1).EntireRow.Insert
arr = Rng
Rng.ClearContents
Cells(r, 5).Resize(c - 4).Value = Application.Transpose(arr)
Next
End Sub

[jisaacreese]

AMAZING! Thanks for getting me un-stuck on this. I really appreciate it! The code works great for this operation.