Move rows into columns

[shlomek12]

Hi

I want to move a lot of rows into columns

Here is attached a small clip what I need

https://www.screencast.com/t/ATXeMzkNi

Can somebody help me?

 

[footoo]

Sub ColumnToRows()
Dim rng As Range, area As Range
Application.ScreenUpdating = False
Range([A4], Cells(Rows.Count, "A").End(xlUp)) _
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
[A:A].Insert
Range([A4], Cells(Rows.Count, "B").End(xlUp)(1, 0)) _
    .Formula = "=IF(B4=""Product"",1,"""")"
Set rng = Range([A4], Cells(Rows.Count, "A").End(xlUp)) _
    .SpecialCells(xlCellTypeFormulas, 2).Offset(0, 1)
For Each area In rng.Areas
    area.Copy
    area(0, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next
rng.EntireRow.Delete
[A:A].Delete
Application.ScreenUpdating = True
End Sub