Дробление таблицы на разные листы

[MaxxVer]

Всем здравствуйте!

Прошу помощи, нужен макрос который смог бы сделать следующее:
существует большая таблица (более 20 тыс. строк), состоит она из блоков примерно по 300 строк.
Необходимо, указав количество строк, разбить эту таблицу на n-ое кол-во листов. Т.е берутся первые 300 строк (или другое количество которое я укажу), копируются и вставляются значениями в лист 2, далее берутся следующие 300 строк (по порядку) и копируются в лист 3 и т.д. пока не закончатся данные в первоначальной таблице.
Думаю пример здесь не нужен...
Заранее спасибо!

[Maxx]

Sub TableCut()
    Dim numStart As Long: numStart = InputBox("Укажите с какой строки начать", "Выбор стартовой строки")
    Dim numSumm As Long: numSumm = InputBox("Укажите количество строк", "Выбор количества строк")
    Dim iName As String: iName = InputBox("Введите уникальное имя для группы создаваемых листов", "Имя группы листов")
    
    x = Abs(Int(((Cells(Rows.Count, 1).End(xlUp).Row - numStart + 1) / numSumm) * (-1))) - 1
    Application.ScreenUpdating = False
    For i = 0 To x
        Sheets("Лист1").Select
        Range(Rows(numStart + i * numSumm), Rows(numStart + i * numSumm + numSumm - 1)).Copy
        Sheets.Add After:=Sheets(Sheets.Count): ActiveSheet.Name = iName & i + 1
        Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1).Select: Selection.PasteSpecial Paste:=xlPasteValues
    Next
    Application.CutCopyMode = False: Application.ScreenUpdating = True
End Sub

Выберите исходный лист с данными и запустите макрос.

[MaxxVer]

Сделал как сказано.
Ругается "run-time error 9 subscript out of range".

[SAS888]

С позволения Maxx, код можно немного упростить, используя Step:

Sub TableCut2()
    Dim numStart As Long: numStart = InputBox("Укажите с какой строки начать", "Выбор стартовой строки")
    Dim numSumm As Long: numSumm = InputBox("Укажите количество строк", "Выбор количества строк")
    Dim iName As String: iName = InputBox("Введите уникальное имя для группы создаваемых листов", "Имя группы листов")
    Dim i As Long, j As Long, ws As Worksheet: Application.ScreenUpdating = False: Set ws = ActiveSheet: j = 0
    For i = numStart To ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1 Step numSumm
        Sheets.Add After:=Sheets(Sheets.Count): j = j + 1: ActiveSheet.Name = iName & j
        ws.Range(ws.Cells(i, 1), ws.Cells(i + numSumm - 1, 4)).Copy [A1]
    Next: ws.Activate
End Sub

[MaxxVer]

Понял почему не работало - исходный лист был назван не как "Лист1", поправил теперь все работает.
Спасибо большое!

[MaxxVer]

To SAS888, ваш макрос работает как раз с любым названием листа.
Спасибо.

[MaxxVer]

To SAS888, правда копируются почему то не все столбцы.. а только 4.

[MaxxVer]

Подскажите, пожалуйста, еще: нужно чтобы название листа присваивалось беря значение столбца U. Т.е. копируется блок с 220 по 440 строку, его название содержится в ячейке U220.

[SAS888]

копируются почему то не все столбцы.. а только 4.

нужно чтобы название листа присваивалось беря значение столбца U

Можно так:

Sub TableCut2()
    Dim numStart As Long: numStart = InputBox("Укажите с какой строки начать", "Выбор стартовой строки")
    Dim numSumm As Long: numSumm = InputBox("Укажите количество строк", "Выбор количества строк")
    Dim i As Long, j As Long, ws As Worksheet: Application.ScreenUpdating = False: Set ws = ActiveSheet
    For i = numStart To ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1 Step numSumm
        Sheets.Add After:=Sheets(Sheets.Count): ActiveSheet.Name = ws.Cells(i, "U")
        ws.Rows(i & ":" & i + numSumm - 1).Copy [A1]
    Next: ws.Activate
End Sub

Только... макрос не проверяет, существует лист с таким названием, или нет. Чтобы вставить такую проверку, укажите, что нужно делать в этом случае.
Также, не проверяется правильность ввода исходных данных (номер 1-й строки и количество строк в блоке). Если нужно, добавьте такую проверку самостоятельно.

[MaxxVer]

Спасибо. Дополнительные условия не требуются, всё работает.