VBA to Split 1 sheet to multiple sheets

[C.R.]

Hello,

We are Still using Excel 2003 here at work.

I have a set of data that is 15,000 rows.
It needs to be split into 50 separate tabs of 300 rows of data each (Row 1-300 = Tab1 , Rows (301 - 600 would be Tab 2 etc.) The # of rows for each sub tab could change from 300 to another number ... say 400... from time to time as well. It depends on the work load at the time.

Any help would be appreciated. Thanks in advance.

K

 

[venkat1926]

data is Sheet1 with row 1 is having column heading
copy Sheet1 to Sheet2 also as a safe action

now try to run this macro "TEST" on COPY OF THE ORIGINAL FILE AND NOT IN THE ORIGINAL FILE

Sub test()
Dim lastrow As Long, sset As Long, j As Long
Worksheets("sheet1").Activate
lastrow = Range("A1").End(xlDown).Row
sset = InputBox("type the number of rows to be split e.g. 300 or 400")
j = 0
Do
'MsgBox j * sset + 2
'MsgBox j * sset + 2 + sset - 1
If j * sset + 2 > lastrow Then Exit Do
Range(Cells(j * sset + 2, 1), Cells(j * sset + 2 + sset - 1, 1)).EntireRow.Copy
Worksheets.Add
ActiveSheet.Name = j * sset + 2 + j
With ActiveSheet
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
End With
Worksheets("sheet1").Activate
j = j + 1

Loop
End Sub

Sub undo()
Dim j As Long, sset As Long
Application.DisplayAlerts = False
For j = Worksheets.Count To 1 Step -1
If Worksheets(j).Name = "Sheet1" Or Worksheets(j).Name = "Sheet2" Then GoTo nextj
Worksheets(j).Delete
nextj:
Next j

Application.DisplayAlerts = True
End Sub

 

[C.R.]

venkat1926,

That's a million times better than what I had come up with.

I noticed the Header Row 1 does not copy over to the split sheets.
I cannot decipher your code, so I do not know how to fix this.
Could you edit?

Thank you very much for this. This will save many hours of work.

C.R.

 

[venkat1926]

"I noticed the Header Row 1 does not copy over to the split sheets.
I cannot decipher your code, so I do not know how to fix this.
Could you edit? "

edited macro test is

Sub test()
Dim lastrow As Long, sset As Long, j As Long, hdng As String, k As Long
Worksheets("sheet1").Activate
lastrow = Range("A1").End(xlDown).Row
sset = InputBox("type the number of rows to be split e.g. 300 or 400")
j = 0
Do
ActiveWorkbook.Names.Add Name:="hdng", RefersToR1C1:="=Sheet1!R1"
'MsgBox j * sset + 2
'MsgBox j * sset + 2 + sset - 1
If j * sset + 2 > lastrow Then Exit Do
Range(Cells(j * sset + 2, 1), Cells(j * sset + 2 + sset - 1, 1)).EntireRow.Copy
Worksheets.Add
ActiveSheet.Name = j * sset + 2 + j
With ActiveSheet
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
 End With
Worksheets("sheet1").Activate
j = j + 1
Loop
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> "Sheet1" Or Worksheets(k).Name <> "Sheet2" Then
 Worksheets("sheet1").Range("hdng").Copy
 Worksheets(k).Activate
Range("A1").PasteSpecial

End If
Next k
End Sub

 

[C.R.]

Thank you again venkat1926.

C.R.