VBA: Split Data Sets Into Sub Sets and Save

skate1991

New Member
Joined
Dec 19, 2011
Messages
15
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
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
VBA Code:
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
 
Upvote 0
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.
 
Upvote 0
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.

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,100
Members
452,301
Latest member
QualityAssurance

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top