Split large list into several sheets

[lilgreen]

Hello,

I have a very large list of emails around 200,000 and I need to split them into several sheets of 40,000 on each. I have been able to accomplish this with the following but how do I copy the headers over to each sheet?

Sub SplitWorksheet()Dim lngLastRow As Long
Dim lngNumberOfRows As Long
Dim lngI As Long
Dim strMainSheetName As String
Dim currSheet As Worksheet
Dim prevSheet As Worksheet
'Number of rows to split among worksheets
lngNumberOfRows = 40000
'Current worksheet in workbook
Set prevSheet = ThisWorkbook.ActiveSheet
'First worksheet name
strMainSheetName = prevSheet.Name
'Number of rows in worksheet
lngLastRow = prevSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Worksheet counter for added worksheets
lngI = 1
While lngLastRow > lngNumberOfRows
Set currSheet = ThisWorkbook.Worksheets.Add
With currSheet
.Move after:=Worksheets(Worksheets.Count)
.Name = strMainSheetName + "(" + CStr(lngI) + ")"
End With


With prevSheet.Rows(lngNumberOfRows + 1 & ":" & lngLastRow).EntireRow
.Cut currSheet.Range("A1")
End With


lngLastRow = currSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set prevSheet = currSheet
lngI = lngI + 1
Wend
End Sub

 

[My Aswer Is This]

I wrote my script this way:

Note please modify Total Rows and number rows to copy to each new sheet as needed
My script as written uses 406 Total rows and to copy 10 rows at a time.
I did not want to test on 40,000 rows

You will see my note on this in the script marked in red.

My script copies the rows over does not cut them over. This allows you to delete the rows from Master sheet later if you want.

Sub Copy_Rows()
'Modified 5/10/2019 11:26:27 PM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim x As Long
Dim n As Long
Dim Total As Long
Total = 406 ' [COLOR=#ff0000]Modify to Total number of rows in your case 200,000[/COLOR]
n = 10 '[COLOR=#ff0000]Modify to number of rows to copy to each sheet in your case 40,000[/COLOR]
x = 2
Dim s As Long
s = 1
For i = 1 To Total Step n
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = Sheets(1).Name & "(" & s & ")"
    Sheets(1).Rows(1).Copy Sheets(Sheets(1).Name & "(" & s & ")").Rows(1)
    Sheets(1).Rows(x).Resize(n).Copy Sheets(Sheets(1).Name & "(" & s & ")").Rows(2)
    x = x + n
    s = s + 1
Next
Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

Try this

Sub SplitWorksheet()
    Dim nRows As Long, i As Long, sh As Worksheet, r As Range, n As Long
    
    Set sh = ThisWorkbook.ActiveSheet       'Current worksheet in workbook
    nRows = 4                               'Number of rows to split among worksheets
    n = 1
    
    For i = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row Step nRows
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = sh.Name & "(" & n & ")"
        Set r = Union(sh.Rows(1), sh.Rows(i).Resize(nRows))
        r.Copy Range("A1")
        n = n + 1
    Next
End Sub

 

[lilgreen]

This is perfect ty

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.