Section several thousand rows into sheets with 500 rows each

[mfitz51]

Hello,

I'm going to be processing submissions of up to 5000 rows + 1 header row. I have to import this data into an online document that can only host 500 rows (+header) per table. So for example, if I get 2000 rows, I would have to split them into 4 tables. I'd like the header + 500 rows to copy to a new sheet named 1-500, then rows 501-1000 to copy to another sheet, etc. Each sheet should have the header. I can provide an example with the headers if that would be helpful.

 

[HighAndWilder]

Hello,

I'm going to be processing submissions of up to 5000 rows + 1 header row. I have to import this data into an online document that can only host 500 rows (+header) per table. So for example, if I get 2000 rows, I would have to split them into 4 tables. I'd like the header + 500 rows to copy to a new sheet named 1-500, then rows 501-1000 to copy to another sheet, etc. Each sheet should have the header. I can provide an example with the headers if that would be helpful.

Try this on a copy of your data.

If the sheets do not exist then they are created.

Change the sheet name 'Data' to the name of your sheet containing your source data.

Public Sub subSplitData()
Dim strSheet As Variant
Dim Ws As Worksheet
Dim i As Integer

  Set Ws = Worksheets("Data") ' <<<< Change the worksheet name here.
   
  For i = 2 To Ws.Range("A1").CurrentRegion.Rows.Count Step 500
    strSheet = i - 1 & " - " & i + 500 - 2
    If Not Evaluate("isref('" & strSheet & "'!A1)") Then
       Worksheets.Add after:=Sheets(Sheets.Count)
       ActiveSheet.Name = strSheet
     End If
     With Worksheets(strSheet)
       .Cells.Clear
       Ws.Rows(1).Copy Destination:=.Rows(1)
       Ws.Range("A" & i).Resize(500, Ws.Cells(1, Columns.Count).End(xlToLeft).Column).Copy Destination:=.Range("A2")
       .Cells.EntireColumn.AutoFit
     End With
  Next i
  
End Sub