Option Explicit
Sub SplitIntoBatches_999PlusHeader()
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim startDataRow As Long, endDataRow As Long
Dim batchSize As Long: batchSize = 999 'data rows per file (header excluded)
Dim outFolder As String
Dim prefix As String
Dim i As Long, fileIndex As Long
'=== CONFIG ===
Set ws = ActiveSheet 'or: Set ws = ThisWorkbook.Worksheets("Sheet1")
outFolder = "D:\OneDrive - palawanpawnshop.com\Documents\Services Files\ELN\" '<< change this
prefix = "ELN_" '<< change this (e.g., DLRT_, DMT_, etc.)
'==============
'Find used range bounds
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
If lastRow < 2 Then
MsgBox "No data rows found (only header or blank sheet).", vbExclamation
Exit Sub
End If
'Ensure folder exists
If Dir(outFolder, vbDirectory) = "" Then
MkDir outFolder
End If
startDataRow = 2
fileIndex = 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While startDataRow <= lastRow
endDataRow = Application.Min(startDataRow + batchSize - 1, lastRow)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add(xlWBATWorksheet)
'Copy header
ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol)).Copy Destination:=wbNew.Sheets(1).Cells(1, 1)
'Copy data chunk
ws.Range(ws.Cells(startDataRow, 1), ws.Cells(endDataRow, lastCol)).Copy _
Destination:=wbNew.Sheets(1).Cells(2, 1)
'Optional: keep formatting consistent
wbNew.Sheets(1).Columns.AutoFit
'Save file
Dim fileName As String
fileName = outFolder & prefix & Format(fileIndex, "000") & ".xlsx"
wbNew.SaveAs Filename:=fileName, FileFormat:=xlOpenXMLWorkbook
wbNew.Close SaveChanges:=False
fileIndex = fileIndex + 1
startDataRow = endDataRow + 1
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done! Created " & (fileIndex - 1) & " file(s) in:" & vbCrLf & outFolder, vbInformation
End Sub3 views