CODEWITHSUNDEEP
vbaexcelsplit
miodf
miodf

Reputation: 543

Split Excel spreadsheet by variable number of rows (eg: about 5,000 rows plus max 1,000)

How to split an excel file into several files not knowing in advance the exact number of rows where to tell Excel to split, but knowing only a rough number where to split ?

Example: 100,000 rows in total. In Column A, I have many rows which starts by the same cell content. I know that I have a maximum of 1,000 rows that have the same Column A content.

row# : Column A content :

row1:namedBB

row2:namedBB

...

row251:namedBB

row252:namedCC

...

row4,999:namedDD

row5,000:namedDD

...

row5,365:namedDD

row5,366:namedKEI

...etc...

In this example, I would like to split the file to about each 5,000 rows. But in fact the first split should be exactly on 5,366 (so the first xslx file will have content from row1 to row5,365, and the second xslx file will have from row5,366 to ?...).

Here is the VBA code that I use to split with a fixed number of rows.

Sub Splitter_fixed_number_of_rows()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim lTop As Long, lBottom, lCopy As Long
Dim LastRow As Long, LastCol As Long
Dim wbNew As Workbook, sPath As String

With ThisWorkbook.Sheets("recap")  ' sheetname to adapt
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lTop = 2
Do

lBottom = lTop + 5000   ' fixed number of row where to split //to adapt
If lBottom > LastRow Then lBottom = LastRow
lCopy = lCopy + 1

Set wbNew = Workbooks.Add
.Range(.Cells(1, 1), .Cells(1, LastCol)).Copy
wbNew.Sheets(1).Range("A1").PasteSpecial
.Range(.Cells(lTop, 1), .Cells(lBottom, LastCol)).Copy
wbNew.Sheets(1).Range("A2").PasteSpecial

wbNew.SaveAs Filename:="TEST_" & Application.ActiveWorkbook.FullName & lCopy, FileFormat:=xlOpenXMLWorkbook ' split into .xslx files
wbNew.Close

lTop = lBottom + 1
Loop While lTop <= LastRow
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Thanks ;)

Upvotes: 3

Views: 1799

Answers (3)

snb
snb

Reputation: 343

If I interpret your question correctly:

Sub M_snb()
  On Error Resume Next

  Do
    With Columns(1).SpecialCells(2)
      If Err.Number <> 0 Then Exit Sub

      .Cells(1).Resize(Application.Match(.Cells(1).Value, .Offset(0), 1)).Cut
      Sheets.Add.Paste
    End With
  Loop
End Sub

Upvotes: 0

user3819867
user3819867

Reputation: 1120

Sub ertdfgcvb()
rcount = 0
nameseries = ""

For i = lTop + 1 To LastRow
cellname = Cells(i, 1)
If rcount > 5000 Then
    If cellname <> nameseries Then
        rcount = 0
        nameseries = cellname
        'generate new file, range that needs be copied is header and Range(Cells(i-rcount,LastColumn),Cells(i,LastColumn)
    End If
rcount = rcount + 1
End If

End Sub

I would simply split the dataset to worksheets, 100,000 isn't that much.

Upvotes: 0

izzymo
izzymo

Reputation: 936

I think you can add the below line of code to dynamically search for the 5xxxth row

Append the following few lines below lCopy = lCopy + 1

For lBottom = lBottom To lBottom + 999
    If Range("A" & lBottom) <> Range("A" & lBottom + 1) Then
        Exit For
    End If
Next lBottom

New Modified Code

Sub Splitter_fixed_number_of_rows()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim lTop As Long, lBottom, lCopy As Long
Dim LastRow As Long, LastCol As Long
Dim wbNew As Workbook, sPath As String

With ThisWorkbook.Sheets("recap")  ' sheetname to adapt
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lTop = 2
Do

lBottom = lTop + 5000   ' fixed number of row where to split //to adapt
lCopy = lCopy + 1

For lBottom = lBottom To lBottom + 999
    If Range("A" & lBottom) <> Range("A" & lBottom + 1) Then
        Exit For
    End If
Next lBottom

If lBottom > LastRow Then lBottom = LastRow

Set wbNew = Workbooks.Add
.Range(.Cells(1, 1), .Cells(1, LastCol)).Copy
wbNew.Sheets(1).Range("A1").PasteSpecial
.Range(.Cells(lTop, 1), .Cells(lBottom, LastCol)).Copy
wbNew.Sheets(1).Range("A2").PasteSpecial

wbNew.SaveAs Filename:="TEST_" & Application.ActiveWorkbook.FullName & lCopy, FileFormat:=xlOpenXMLWorkbook ' split into .xslx files
wbNew.Close

lTop = lBottom + 1
Loop While lTop <= LastRow
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Upvotes: 1

Related Questions