How to split excel sheet into multiple files based on rows

Question

#2

Make the worksheet with the data the active sheet and run this. It should save to the same path as the csv.

Table of Contents Show

How do I split an Excel spreadsheet into multiple worksheets based on rows without VBA?
How do I split data in Excel with criteria?
How do I pull data from one sheet into multiple sheets?

VBA Code:

Sub flyguy()

Dim ACS As Range, Z As Long, New_WB As Workbook, _
Total_Columns As Long, Start_Row As Long, Stop_Row As Long, Copied_Range As Range

Dim Headers() As Variant

Set ACS = ActiveSheet.UsedRange

With ACS

    Headers = .Rows(1).Value
    Total_Columns = .Columns.Count
    
End With

Start_Row = 2

Do While Stop_Row <= ACS.Rows.Count
    
    Z = Z + 1
    
    If Z > 1 Then Start_Row = Stop_Row + 1
    
    Stop_Row = Start_Row + 499
    
    With ACS.Rows
        If Stop_Row > .Count Then Stop_Row = .Count
    End With
    
    With ACS
        Set Copied_Range = .Range(.Cells(Start_Row, 1), .Cells(Stop_Row, Total_Columns))
    End With
    
    Set New_WB = Workbooks.Add
    
    With New_WB
    
        With .Worksheets(1)
            .Cells(1, 1).Resize(1, Total_Columns) = Headers
            .Cells(2, 1).Resize(Copied_Range.Rows.Count, Total_Columns) = Copied_Range.Value
        End With
        
       .SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
       .Close
       
    End With
    
    If Stop_Row = ACS.Rows.Count Then Exit Do
    
Loop

End Sub

#3

Make the worksheet with the data the active sheet and run this. It should save to the same path as the csv.

VBA Code:

Sub flyguy()

Dim ACS As Range, Z As Long, New_WB As Workbook, _
Total_Columns As Long, Start_Row As Long, Stop_Row As Long, Copied_Range As Range

Dim Headers() As Variant

Set ACS = ActiveSheet.UsedRange

With ACS

    Headers = .Rows(1).Value
    Total_Columns = .Columns.Count
   
End With

Start_Row = 2

Do While Stop_Row <= ACS.Rows.Count
   
    Z = Z + 1
   
    If Z > 1 Then Start_Row = Stop_Row + 1
   
    Stop_Row = Start_Row + 499
   
    With ACS.Rows
        If Stop_Row > .Count Then Stop_Row = .Count
    End With
   
    With ACS
        Set Copied_Range = .Range(.Cells(Start_Row, 1), .Cells(Stop_Row, Total_Columns))
    End With
   
    Set New_WB = Workbooks.Add
   
    With New_WB
   
        With .Worksheets(1)
            .Cells(1, 1).Resize(1, Total_Columns) = Headers
            .Cells(2, 1).Resize(Copied_Range.Rows.Count, Total_Columns) = Copied_Range.Value
        End With
       
       .SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
       .Close
      
    End With
   
    If Stop_Row = ACS.Rows.Count Then Exit Do
   
Loop

End Sub

This is Fantastik!! Thank you so much!!! I have ran a quick test on this and it seems to do exactly what I was looking for in the blink of an eye. Is there a way to save this so every time I open excel I do not have to copy/paste into the module? Will run some more tests after the holiday. I never knew excel was this powerful.

#4

This is Fantastik!! Thank you so much!!! I have ran a quick test on this and it seems to do exactly what I was looking for in the blink of an eye. Is there a way to save this so every time I open excel I do not have to copy/paste into the module? Will run some more tests after the holiday. I never knew excel was this powerful.

You can place it inside a module in the Personal workbook and run it from there.

#5

You can place it inside a module in the Personal workbook and run it from there.

Placing it there worked as expected thank you.
One additional question. After I run the macro the first time the files are created as expected, File-1,File-2,File-3 etc. If I get another file and try to run the macro it does not create a new file with an increase the file names such as File-4, File-5 it says --A file name already exists in this location do you want to overwrite it(looks to be putting in in the same location as the first File-1)
Is there a workaround for this? Can the file naming just continue?
If I hit no When I debug the below is highlighted
.SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143

#6

Placing it there worked as expected thank you.
One additional question. After I run the macro the first time the files are created as expected, File-1,File-2,File-3 etc. If I get another file and try to run the macro it does not create a new file with an increase the file names such as File-4, File-5 it says --A file name already exists in this location do you want to overwrite it(looks to be putting in in the same location as the first File-1)
Is there a workaround for this? Can the file naming just continue?
If I hit no When I debug the below is highlighted
.SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143

VBA Code:

Sub flyguy()

Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _
Total_Columns As Long, Start_Row As Long, Stop_Row As Long, Copied_Range As Range, File_Name As String

Dim Headers() As Variant

Set ACS = ActiveSheet.UsedRange

With ACS
    Headers = .Rows(1).Value
    Total_Columns = .Columns.Count
End With

File_Name = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls")

On Error GoTo Next_File

Do While Len(File_Name) > 0

    If File_Name Like "*file-*" Then
    
        B = CLng(Split(Split(File_Name, "file-")(1), ".xls")(0))
        
        If B > Z Then Z = B
    
    End If
    
Next_File: On Error GoTo -1
    
    File_Name = Dir
    
Loop

On Error GoTo 0

Start_Row = 2

Do While Stop_Row <= ACS.Rows.Count
    
    Z = Z + 1
    
    If Z > 1 Then Start_Row = Stop_Row + 1
    
    Stop_Row = Start_Row + 499
    
    With ACS.Rows
        If Stop_Row > .Count Then Stop_Row = .Count
    End With
    
    With ACS
        Set Copied_Range = .Range(.Cells(Start_Row, 1), .Cells(Stop_Row, Total_Columns))
    End With
    
    Set New_WB = Workbooks.Add
    
    With New_WB
    
        With .Worksheets(1)
            .Cells(1, 1).Resize(1, Total_Columns) = Headers
            .Cells(2, 1).Resize(Copied_Range.Rows.Count, Total_Columns) = Copied_Range.Value
        End With
        
       .SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
       .Close
       
    End With
    
    If Stop_Row = ACS.Rows.Count Then Exit Do
    
Loop

End Sub

#7

VBA Code:

Sub flyguy()

Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _
Total_Columns As Long, Start_Row As Long, Stop_Row As Long, Copied_Range As Range, File_Name As String

Dim Headers() As Variant

Set ACS = ActiveSheet.UsedRange

With ACS
    Headers = .Rows(1).Value
    Total_Columns = .Columns.Count
End With

File_Name = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xls")

On Error GoTo Next_File

Do While Len(File_Name) > 0

    If File_Name Like "*file-*" Then
   
        B = CLng(Split(Split(File_Name, "file-")(1), ".xls")(0))
       
        If B > Z Then Z = B
   
    End If
   
Next_File: On Error GoTo -1
   
    File_Name = Dir
   
Loop

On Error GoTo 0

Start_Row = 2

Do While Stop_Row <= ACS.Rows.Count
   
    Z = Z + 1
   
    If Z > 1 Then Start_Row = Stop_Row + 1
   
    Stop_Row = Start_Row + 499
   
    With ACS.Rows
        If Stop_Row > .Count Then Stop_Row = .Count
    End With
   
    With ACS
        Set Copied_Range = .Range(.Cells(Start_Row, 1), .Cells(Stop_Row, Total_Columns))
    End With
   
    Set New_WB = Workbooks.Add
   
    With New_WB
   
        With .Worksheets(1)
            .Cells(1, 1).Resize(1, Total_Columns) = Headers
            .Cells(2, 1).Resize(Copied_Range.Rows.Count, Total_Columns) = Copied_Range.Value
        End With
       
       .SaveAs ACS.Parent.Parent.Path & Application.PathSeparator & "file-" & Z & ".xls", FileFormat:=-4143
       .Close
      
    End With
   
    If Stop_Row = ACS.Rows.Count Then Exit Do
   
Loop

End Sub

The new code

#8

Getting an error and the below text is red

Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _

#9

Getting an error and the below text is red
Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _

add a space after the last comma

#10

add a space after the last comma

did that and get compile error and Sub flyguy() is yellow
Sub flyguy()

Dim ACS As Range, Z As Long, New_WB As Workbook, B As Long, _

How do I split an Excel spreadsheet into multiple worksheets based on rows without VBA?

With Split Table Wizard you will.

On Step 1 choose your range..

On Step 2 select one or more key columns for splitting..

On Step 3 choose destination for the resulting split tables..

On Step 4 select additional options: worksheets names, header and formatting..

How do I split data in Excel with criteria?

Try it!.

Select the cell or column that contains the text you want to split..

Select Data > Text to Columns..

In the Convert Text to Columns Wizard, select Delimited > Next..

Select the Delimiters for your data. ... .

Select Next..

Select the Destination in your worksheet which is where you want the split data to appear..

How do I pull data from one sheet into multiple sheets?

One way to do this is to type the text in one worksheet, and then copy and paste the text into the other worksheets. If you have several worksheets, this can be very tedious. An easier way to do this is to use the CTRL key to group worksheets.

kode excel Separate table Excel