Sub CopyPasteTranspose()
    Dim i       As Long
    Dim LastRow As Long
    Dim ws      As Worksheet: Set ws = Sheets("Sheet1") 'Change Worksheet to suit
    Application.ScreenUpdating = False
    With ws
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        .Rows("1:1").Insert Shift:=xlDown
        .Range("H1").Value = "Hdr"
        .Range("H2:H" & .Range("A" & .Rows.Count).End(xlUp).Row).Formula = "=COUNTIF($A$2:A2,A2)"
        For i = 2 To LastRow Step 8
            .Range("A" & i).Resize(6).Copy
            .Range("B" & i).PasteSpecial xlPasteAll, , , Transpose:=True
        Next i
        With .Range("H1", .Range("H" & .Rows.Count).End(xlUp))
            .AutoFilter Field:=1, Criteria1:=">1", Criteria2:="0", Operator:=xlOr
            .Offset(1).EntireRow.Delete
            .AutoFilter
        End With
        .Rows("1:1").Delete Shift:=xlUp
        .Columns("H:H").EntireColumn.Delete
    End With
    Application.Goto [A1]
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub