Option Explicit

Sub XCopy()
Dim x As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long

    i = 0
    m = ActiveSheet.Cells(Application.Rows.Count, "H").End(xlUp).Row
    ' Clear Output
    Sheet2.Range("A1:P10").ClearContents
    With Sheet1
        ' Find Rows with "1s"
        For k = 1 To m
            If .Cells(k, 8) = "1s" Then
              j = k
              i = i + 1
              x = 1
              ' Loop till Step is over
              Do
                .Range("A" & j).Resize(, 4).Copy Destination:=Sheet2.Cells(i, x)
                x = Sheet2.Cells(i, Application.Columns.Count).End(xlToLeft).Column + 1
                j = j + 1
              Loop Until .Cells(j - 1, 8) = "1f"
            End If
        Next k
    End With
End Sub