Sorting Data - copy only needed data (macro)

Try

Sub test()
    Dim myAreas As Areas, i As Long
    On Error Resume Next
    Set myAreas = Sheets("sheet1").Columns("b").SpecialCells(2).Areas
    On Error GoTo 0
    If myAreas Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    For i = 1 To myAreas.Count
        With myAreas(i)
            Sheets("sheet2").Cells(i + 1, 2).Value = .Cells(0, 0).Value
            .Rows(2).Offset(, 1).Resize(, .CurrentRegion.Columns.Count).Copy _
            Sheets("sheet2").Cells(i + 1, 3)
        End With
    Next
    Set myAreas = Nothing
    Application.ScreenUpdating = True
End Sub