a l aide !!! casse tete découpe + entete de 6 lignes

Sub Decoupe()
Dim d As Range, r As Range, pfile$, x#, j#, ws As Worksheet
nb = InputBox("Combien de lignes faut-il créer ?", "DECOUPAGE FICHIER")
If IsEmpty(nb) Or Not IsNumeric(nb) Then Exit Sub
Set d = ActiveSheet.UsedRange
tablo1 = d.Resize(6)
pfile = ActiveWorkbook.Path
x = d.Rows.Count
j = 1
Application.ScreenUpdating = False
For i = 6 To x Step Int(nb)
    tablo2 = d.Offset(i).Resize(Int(nb)).Value
    Set ws = Sheets.Add
    With ws
        .Cells(1, 1).Resize(6, UBound(tablo1, 2)) = tablo1
        .Cells(7, 1).Resize(UBound(tablo2, 1), UBound(tablo2, 2)) = tablo2
        Erase tablo2
        .Copy
        Application.DisplayAlerts = False 'attention: écrase les fichiers existants
        With ActiveWorkbook
            .SaveAs pfile & "\import rejets de prélèvements" & j & " (Dec" & nb & ")" & ".xls"
            .Close True
        End With
        .Delete
        Application.DisplayAlerts = True
    End With
    j = j + 1
Next
Application.ScreenUpdating = True
End Sub