Split woksheet every 400 lines onto multiple sheets

[Bliemcc]

VBA Excel 2007

I need to be able to split one worksheet into multiple worksheets with a maxiimum of 400 lines.

Help
Cindy

[Tommy]

What would be the criteria to split on?
Do we just count 400 lines and put it in another sheet?
Is the data sorted or do we need to search for all of the data?
Do you have a sample worksheet with all of the personal/confidential data removed?
Is the data going to go in another workbook or will the current workbook suffice?
Are the sheets added or are they already existing?
How are the sheets named or do we name them and how (so far as the name) or does it matter?

[jolivanes]

Change the Sheet name (here Sheet1) to whatever your Sheet Name with all the info is.
It copies Column A and B. Change the B to your last Column or change the copying to Entire Rows.


Sub TryThis()
Dim LR As Double
Dim TS As Double
Dim i As Double, ii As Double, k As Double
Application.ScreenUpdating = False
LR = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row '<--- Change "Sheet1" to the Sheetname with the many rows of info
TS = WorksheetFunction.RoundUp(LR / 400, 0)
i = 1
ii = 400
For k = 1 To TS
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = i & " - " & ii
Sheets("Sheet1").Range("A" & i, Sheets("Sheet1").Range("B" & ii)).Copy Sheets(Sheets.Count).Range("A1")
i = i + 400
ii = ii + 400
Next k
Sheets("Sheet1").Select
Application.ScreenUpdating = True
End Sub

[jolivanes]

Cindy.
This should do the entire rows.
Please try it on a copy of your workbook first.

Sub TryThis()
Dim LR As Double
Dim TS As Double
Dim i As Double, ii As Double, k As Double
Application.ScreenUpdating = False
LR = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row '<--- Change "Sheet1" to the Sheet Name with the many rows of info
TS = WorksheetFunction.RoundUp(LR / 400, 0)
i = 1
ii = 400
For k = 1 To TS
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = i & " - " & ii
Sheets("Sheet1").Range("A" & i, Sheets("Sheet1").Range("A" & ii)).EntireRow.Copy Sheets(Sheets.Count).Range("A1")
i = i + 400
ii = ii + 400
Next k
Sheets("Sheet1").Select
Application.ScreenUpdating = True
End Sub

[Bliemcc]

I have multiple sheets creted from oneworksheet . all in same workbook.
Once split , I am attempting to review the split sheets, count the rows. A single sheet cannot have more than 400 lines. If over 400 (say 1000). then the sheet needs to be split 3 times (or as many times needed )to get the sheet below 400.

I know what are started below doesnotwork.. just wanted to explain what I need to do.

Call SplitSheets("InvoiceSummary", "F2", -3)

For Indx = 3 To Sheets.count
Sheets(Indx).Activate
counter = counter + 1
Tot = 0
If ActiveSheet.Name <> "InvoiceSummary" Then
shtname = ActiveSheet.Name
ActiveCell.SpecialCells(xlLastCell).Select
Rownum = ActiveCell.row
If Rownum > 900 Then
' Call DelRows("901:Rownum")
Call CopySheet(shtname)
' Selection.Cut
' Sheets.Add
' Selection.Insert
'ActiveSheet.Name = shtname + "_" + "a"
End If
End If
Next
Range("A2").Select

[snb]

Sub M_snb()
For j = 1 To Sheets("sheet1").Cells.SpecialCells(11).Row Step 400
Sheets.Add , Sheets(Sheets.Count)
Sheets("sheet1").Rows(j).Resize(10).Copy Sheets(Sheets.Count).Cells(1)
Next
End Sub

[Bliemcc]

Can you explain what the first lineis doing?

[snb]

Can you tell the results of the testing of this code ?

[Tommy]

The below will break each sheet into sheets with 400 lines or less
Sub BreakASheet(Optional MaxNum As Long = 400)
Dim Ws As Worksheet, mI As Long, NWs As Worksheet
Dim LC As String
With ActiveWorkbook
For Each Ws In .Worksheets
Ws.Activate
mI = LastRow(Ws)
LC = LastColumn(Ws)
If mI > MaxNum Then
While mI > MaxNum
Set NWs = .Worksheets.Add
Ws.Range("A" & CStr(1 + mI - MaxNum), LC & CStr(mI)).Cut NWs.Range("A1", LC & CStr(MaxNum))
mI = mI - 400
Wend
End If
Next
End With
End Sub
Function LastRow(Aws As Worksheet) As Long
LastRow = Aws.Cells(Aws.Rows.Count, "A").End(xlUp).Row
End Function
Function LastColumn(Aws As Worksheet) As String
Dim LC As Long
LC = Aws.UsedRange.Columns(Aws.UsedRange.Columns.Count).Column
If LC < 27 Then
LastColumn = Chr(LC + 64)
End If
End Function