Home Iteratively break out a data file to a template file and save as a new file for every 5,000 rows

Questions

Iteratively break out a data file to a template file and save as a new file for every 5,000 rows

November 29, 2022

I am trying to break out a data file by 5,000 rows due to limitation with a tool. I have a template file that has multiple sheets (I only have to update data on the first sheet titled ‘Service Template’, but I need all tabs present on the newly created files). The tool requires the template file to be used so I have to use that file instead of copying the data to a completely new file. I am also attempting to do this on a Mac, but can use virtual machine if absolutely necessary.

The data file and the template file both start on row 2 as both files have headers.

I have the below code that I have been trying to build out but it is still not working and I am stuck.

Data file sheet = ‘Sheet1’ and Template File Sheet = ‘Service Template’

Sub test()
Dim lastRow As Long, myRow As Long, myBook As Workbook
ActiveSheet.Name = "Sheet1"
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For myRow = 1 To lastRow Step 5000
    Set myBook = Workbooks.Open("/Users/Downloads/Test/TemplateFile.xlsx")
    ThisWorkbook.Sheets("Sheet1").Rows(myRow & ":" & myRow + 4999).EntireRow.Copy myBook.Sheets("Sheet1").Range("A2")
Application.DisplayAlerts = False
myBook.SaveAs Filename:="\Users\Downloads\Test\" & myBook.Name
Application.DisplayAlerts = False
myBook.Close
Next myRow
End Sub

I am looking to transfer 5000 rows (starting row2) from the data file to the template file (starting row2) save as a new file and then keep doing the same process until all of the rows are complete.

>Solution :

Try something like this:

Sub test()
    Const BLOCK_SIZE As Long = 5000
    Dim wsSrc As Worksheet, myBook As Workbook, rngCopy As Range
    
    Set wsSrc = ActiveSheet 'or some other specific sheet
    Set rngCopy = wsSrc.Rows(2).Resize(BLOCK_SIZE)
    Do While Application.CountA(rngCopy) > 0  'loop while range has content
        With Workbooks.Open("/Users/Downloads/Test/TemplateFile.xlsx") 
            rngCopy.Copy .Worksheets("Sheet1").Range("A2")
            .SaveAs "\Users\Downloads\Test\" & "R" & rngCopy.Row & "_" & .Name
            .Close SaveChanges:=True
        End With
        Set rngCopy = rngCopy.Offset(BLOCK_SIZE) 'next block down
    Loop
End Sub