Transpose every 2nd and 3rd line - vba

Question

I am trying to transpose every second and third row to columns B and C and then preferably delete the old rows so that I don't have two unused rows in B and C. I tried recording a macro, which worked for only the selection I made. Then I tried deleting the specific selections and replacing them with an offset range but I keep getting an error in the PasteSpecial line.
Sub SortRawData()
'
' SortRawData Macro
'
' Keyboard Shortcut: Ctrl+q
'
Selection.Offset(1, 0).Resize(Selection.Rows.Count + 2, _
Selection.Columns.Count).Select
ActiveCell.Copy
ActiveCell.Offset(-1, 1).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
I tried initially using Selection everywhere I have ActiveCell but neither seemed to work. I know I am missing the selection for the two rows I want to delete after I transpose the data into column B and C. What I have is a raw data dump of information that is formatted as:
Item1 Weight1 Color1 Item2 Weight2 Color2 Item 3 Weight 3 Color 3
I can get it to transpose one selection at a time by I can't seem to square away the automation of it.
Sub SortRawData2()
'
' SortRawData2 Macro
'
' Keyboard Shortcut: Ctrl+w
'
Selection.Copy
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Rows("2:3").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
This is the initial recorded macro and even it fails debugging at the PasteSpecial line. Any suggestions would be much appreciated!
Thanks!

Answer 1

Try this, then code an autofilter to remove the empty rows:
Sub SortRawData2()
Dim lLastRow As Long, lLoop As Long
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lLoop = 1 To lLastRow Step 3
Cells(lLoop, 2) = Cells(lLoop + 1, 1)
Cells(lLoop, 3) = Cells(lLoop + 2, 1)
Cells(lLoop + 1, 1).Resize(2).ClearContents
Next lLoop
With Range("A1:A" & lLastRow)
.AutoFilter field:=1, Criteria1:="="
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End Sub