Assuming that Sheet "Clean" has the headers in rows 1 and 2, try this macro:
Sub CopyData()
Application.ScreenUpdating = False
Sheets("Clean").UsedRange.Offset(2, 0).ClearContents
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim x As Long
For x = 7 To LastRow Step 6
Cells(x, "A").Copy Sheets("Clean").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Cells(x, "A").Offset(2, 2).Copy Sheets("Clean").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
Cells(x, "A").Offset(2, 3).Copy Sheets("Clean").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
Cells(x, "A").Offset(2, 4).Copy Sheets("Clean").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
Cells(x, "A").Offset(3, 3).Copy Sheets("Clean").Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
Cells(x, "A").Offset(3, 4).Copy Sheets("Clean").Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)
Cells(x, "A").Offset(4, 3).Copy Sheets("Clean").Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
Cells(x, "A").Offset(4, 4).Copy Sheets("Clean").Cells(Rows.Count, "H").End(xlUp).Offset(1, 0)
Next x
Application.ScreenUpdating = True
End Sub
Bookmarks