Try this on a saved copy of your work...this is untested:
Sub SplitUpWithTwoHeaderRows()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim lastrow As Long, x As Long, p As Long, y As String, i As Long, u As Variant, m As Variant
Dim ws As Worksheet
u = Range("Sheet1!A1").Value
m = Range("Sheet1!A2").Value
Worksheets("sheet1").Activate
lastrow = Range("A1").End(xlDown).Row
x = InputBox("How many rows per sheet would you like?")
p = 0
Do
ActiveWorkbook.Names.Add Name:="y", RefersToR1C1:="=Sheet1!R1"
If p * x + 2 > lastrow Then Exit Do
Range(Cells(p * x + 2, 1), Cells(p * x + 2 + x, 1)).EntireRow.Copy
Worksheets.Add
ActiveSheet.Name = p * x + 1 & "-" & p * x + 1 + x - 1
With ActiveSheet
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
End With
Worksheets("sheet1").Activate
p = p + 1
Loop
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> "Sheet1" Or Worksheets(i).Name <> "Sheet2" Then
Worksheets("sheet1").Range("y").Copy
Worksheets(i).Activate
Range("A2").PasteSpecial
Range("A1").Value = u
Range("A2").Value = m
End If
Next i
For Each ws In ActiveWorkbook.Worksheets
ws.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ws.Name
ActiveWorkbook.Close
Next ws
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Bookmarks