How to organize rows with same info in columns?

[joaopauloloyola]

Hello,

I need to take multiple rows with same information as below:

And organize in columns like this:

I have a thousand of these to do and copying and pasting with transpose is not an option

 

[My Aswer Is This]

My script will copy your data from the active sheet and paste it the way you want onto sheet(2)
Now this does do a copy and transpose which you said would take forever and was not a Option.
But even if you had thousands I would not think it would take no longer the a minute or two.

I know of no other way to do this:

Just have a empty sheet(2) where this will be copied to:

Sub Copy_Paste()
'Modified  12/4/2018  1:12:17 PM  EST
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "B").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
    For i = 1 To Lastrow Step 5
        Sheets(1).Cells(i, 2).Resize(5).Copy
        Sheets(2).Cells(Lastrowa, 1).PasteSpecial xlPasteValues, Transpose:=True
        Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
    Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[Fluff]

Hi & welcome to MrExcel.
Another option

Sub CopyTranspose()
   Dim Rng As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("sheet1")
   With Sheets("sheet2")
      .Range("A2:D2").Value = Application.Transpose(Ws.Range("A1:A4").Value)
      For Each Rng In Ws.Range("B1", Ws.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
         .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(Rng.Value)
      Next Rng
   End With
   
End Sub

 

[My Aswer Is This]

If my code worked why would you suggest another option.

Hi & welcome to MrExcel.
Another option

Sub CopyTranspose()
   Dim Rng As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("sheet1")
   With Sheets("sheet2")
      .Range("A2:D2").Value = Application.Transpose(Ws.Range("A1:A4").Value)
      For Each Rng In Ws.Range("B1", Ws.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
         .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(Rng.Value)
      Next Rng
   End With
   
End Sub

 

[Fluff]

Simply to give the OP another option

 

[My Aswer Is This]

If you do have hyperlinks in those cells you would need this script:

Sub Copy_Paste()
''Modified  12/4/2018  1:52:28 PM  EST
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "B").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
For i = 1 To Lastrow Step 5
    Sheets(1).Cells(i, 2).Resize(5).Copy
    Sheets(2).Cells(Lastrowa, 1).PasteSpecial , Transpose:=True
    Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub