VBA to split workbook every 500 rows but keep header row

[The Gent]

Hi,

I need help splitting an excel worksheet which contains 20k rows into separate workbooks.

I want to keep the first row and have this in each of the extracts. I am thinking of splitting every 500 rows, therefore having 40 workbooks.

I need to retain the format of the original worksheet as the cells have validations rules etc.

The extracts I need to save down with a unique reference, it doesn't really matter what this reference is.

 

[My Aswer Is This]

A lot more information will be needed to help with this question.
Are you sure you want to split one Worksheet into different Workbooks?
Or do you mean different Worksheets.
And how would all these new Worksheets or Workbooks be named.

The more you split things out the more difficult it gets some day when you want to work with your data.

Getting how many sales were made in the last 5 years can be easy if all your data is in one sheet.
But if you have to look at sheets in 20 different Workbooks would be much harder. Looking at 20 different sheets in the same Workbook would be easier.

 

[EXCEL MAX]

I have created code procedure to resolve your problem.
I hope so that will be useful for you and anyone who got similar problem.
Put this in module and run.

Option Explicit

 Dim varNSplitedRows, varNColumns, varNRows, varNLoop  As Long
 Dim varWorksheetName, varTempWorksheet, varLocation, varFileName, _
        varFileExists, varMessage As String
        
Sub SplitToWorkbooks()

    Application.ScreenUpdating = False
    varNSplitedRows = 500
    varWorksheetName = ActiveSheet.Name
    varNColumns = Sheets(varWorksheetName). _
        Cells(1, Columns.Count).End(xlToLeft).Column
    varNRows = Sheets(varWorksheetName). _
        Cells(Rows.Count, 1).End(xlUp).Row
    Sheets.Add
    varTempWorksheet = ActiveSheet.Name
    Sheets(varWorksheetName).Activate
    Range("A1", Cells(1, varNColumns)).Copy _
        Destination:=Sheets(varTempWorksheet).Range("A1")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            varLocation = .SelectedItems(1)
            For varNLoop = 1 To Int(Round((varNRows - 1) / varNSplitedRows, 0)) + 1
                Sheets(varWorksheetName).Activate
                Sheets(varWorksheetName).Range(Cells((varNLoop - 1) * varNSplitedRows + 2, 1), _
                    Cells((varNLoop - 1) * varNSplitedRows + varNSplitedRows + 1, varNColumns)).Copy _
                Destination:=Sheets(varTempWorksheet).Range("A" & (varNLoop - 1) * varNSplitedRows + 2)
                Sheets(varTempWorksheet).Activate
                Sheets(varTempWorksheet).Range(Cells((varNLoop - 1) * varNSplitedRows + 2, 1), _
                    Cells((varNLoop - 1) * varNSplitedRows + varNSplitedRows + 1, varNColumns)).Copy
                Workbooks.Add
                ActiveSheet.Paste
                varFileName = varLocation & "\SplitedWorkbook" & varNLoop & ".xlsx"
                varFileExists = Dir(varFileName)
                If varFileExists = "" Then
                    GoTo SaveFile
                Else
                    varMessage = MsgBox("This file already exist. Do you want to replace it?", _
                        vbYesNo, "DOUBLE FILE ERROR")
                    If varMessage = vbYes Then
                        GoTo SaveFile
                    Else
                        GoTo SkipSave
                    End If
                End If
SaveFile:
                Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs Filename:=varLocation & "\SplitedWorkbook" & varNLoop & ".xlsx"
SkipSave:
                ActiveWorkbook.Saved = True
                ActiveWindow.Close
            Next
        End If
    End With
    ActiveSheet.Delete
    Application.ScreenUpdating = True
 
End Sub