VBA: Split Data Sets Into Sub Sets and Save

[skate1991]

Hey

I was hoping for some help with a little problem I am facing.
I have a data set which is roughly 120,000 rows & 26 columns.

I need to split these into individual workbooks 1000 rows each copy and paste them into a new excel and save them into a folder on my desktop called product split.

If its possible to add the column headers to each workbook that would be much appreciated.
The file needs to be saved in an Excel 97 - 2003 workbook

For example, It would create 120 workbooks.

if it's possible for the file save names to be set 1, set 2 etc

Thanks in advance for any help or suggestions on how best to handle this scenario.

I hope you all have a good day.

Thanks

 

[rakesh seebaruth]

Sub SplitData()
    Dim i As Long, j As Long
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim LastRow As Long
    Dim FileName As String
    
    Set ws = ThisWorkbook.Sheets("Sheet1") 'change "Sheet1" to the actual sheet name
    LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    For i = 1 To LastRow Step 1000
        Set wb = Workbooks.Add
        ws.Range("A1:Z" & i + 999).Copy wb.Sheets(1).Range("A1")
        FileName = "C:\Product Split\Set" & j & ".xls" 'change "C:\Product Split\" to the desired folder path
        wb.SaveAs Filename:=FileName, FileFormat:=56
        j = j + 1
        wb.Close False
    Next i
End Sub

 

[rakesh seebaruth]

If you need to add the column headers to each workbook, you can modify the code by adding ws.Range("A1:Z1").Copy wb.Sheets(1).Range("A1") before the ws.Range("A1:Z" & i + 999).Copy wb.Sheets(1).Range("A1") line.

 

[smozgur]

Another VBA code.
Please see the If i > 10 Then Exit Do code line at the bottom of the loop. I put it there so you won't have to create hundreds of workbooks before making sure it does what you need.

I commented on the code at each step, but let us know if you have any questions about the code.

Assumptions:
1- Source data starts at the A1.
2- All columns and rows with data will be copied.

Sub splitWorksheet()
Dim sht As Worksheet
Dim rng As Range
Dim rngHead As Range
Dim wrk As Workbook
Dim lngRows As Long
Dim strPath As String
Dim i As Integer

    ' Row count to be copied
    lngRows = 1000
    ' Target folder path - you can change as you need
    strPath = Environ("USERPROFILE") & "\Desktop\product split\"
    
    ' Avoid screen flickering
    Application.ScreenUpdating = False

    ' The active sheet data will be copied - change if necessary
    Set sht = ActiveSheet
    
    ' Header row
    Set rngHead = sht.Cells(1, 1).CurrentRegion.Resize(1)
    ' First nth rows to be copied
    Set rng = rngHead.Offset(1).Resize(lngRows)
    
    ' Loop until the first cell in the next batch is empty
    Do Until rng.Cells(1, 1).Value = ""
        ' Do not lock the application so you can use Ctrl + Break to stop execution
        DoEvents
        ' Counter for the file name
        i = i + 1
        ' Create a new workbook
        Set wrk = Application.Workbooks.Add
        With wrk
            ' Merge the header and the data rows and copy into the new workbook
            Union(rngHead, rng).Copy .Worksheets(1).Cells(1, 1)
            ' Save the workbook with the required file format
            wrk.SaveAs strPath & Format(i, "000") & ".xls", xlExcel8
            ' Close the workbook
            .Close False
        End With
        ' Get the next data range
        Set rng = rng.Offset(lngRows)
        
        ' Following stops the execution
        ' after creating a few files for testing purposes
        ' Remove the following code line when you are sure
        ' it works as you need
        If i > 10 Then Exit Do
        
    Loop
    
    ' Set the screen updating property as true
    Application.ScreenUpdating = True
    
End Sub