Таблицу с разделителями Excel с переменным числом строк (например, около 5000 строк плюс макс. 1000)

Question

Как разбить файл excel на несколько файлов, не зная заранее, точное количество строк, в которых следует указывать Excel для разделения, но только знание грубое число, где нужно разделить?

Пример: Всего 100 000 строк. В столбце A у меня много строк, которые начинаются с одного и того же содержимого ячейки. Я знаю, что у меня есть максимум 1000 строк, которые имеют одинаковое содержимое столбца A.

строка #: Колонка A Содержание:

Row1: namedBB

row2: namedBB

...

row251: namedBB

row252: namedCC

. ..

row4,999: namedDD

row5,000: namedDD

...

row5,365: namedDD

row5,366: namedKEI

. ..etc ...

В этом примере я хотел бы разделить файл на eac h 5000 строк. Но на самом деле первый сплит должен быть точно на 5,366 (поэтому первый файл xslx будет иметь контент от строки1 до строки5,365, а второй файл xslx будет иметь от строки 5,366 до? ...).

Вот код VBA, который я использую для разделения с фиксированным количеством строк.

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 

Спасибо;)

Answer 1

Я думаю, вы можете добавить строку ниже кода динамически искать 5xxxth строки

Append следующие несколько строк ниже lCopy = lCopy + 1

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

Новый Модифицированный код

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 

Answer 2

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 

Я бы просто разделил набор данных на рабочие листы, 100 000 - это не так много.

Answer 3

Если интерпретировать ваш вопрос правильно:

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