JustPaste
HomeCategoriesAboutDonateContactTerms of UsePrivacy Policy
JustPaste

Free online notepad — write and share instantly

Navigate

  • Home
  • Timeline
  • Categories

Info

  • About
  • Donate
  • Contact

Legal

  • Terms of Use
  • Privacy Policy

© 2026 JustPaste.app. All rights reserved.

Made with ♥ by JustPaste

Option Explicit | JustPaste.app
about 1 month ago3 views
👨‍💻Programming

Option Explicit

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 Sub
← Back to timeline