Как разделить данные на несколько листов, где есть, например, 3 строки заголовка?

Question

Я изучаю VBA, у меня есть этот код, который я нашел в сети и который отлично подходит для разделения моих таблиц данных.Проблема в том, что у меня теперь есть новая программа, которую я разделяю, для которой есть три строки заголовка, которые должны быть на каждом листе.

Спасибо!

Sub SplitDataNrows()

Dim N As Long, H As Long, rw As Long, lr As Long, Titles As Boolean

If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, _
            "Confirm") = vbNo Then Exit Sub
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
    If N = 0 Then Exit Sub
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
            "Titles?") = vbYes Then Titles = True

Application.ScreenUpdating = False
With ActiveSheet
    lr = .Range("A" & .Rows.Count).End(xlUp).Row

    For rw = 1 + ---Titles To lr Step N
        Sheets.Add
        If Titles Then
            .Rows(1).Copy Range("A1")
            .Range("A" & rw).Resize(N).EntireRow.Copy Range("A2")
        Else
            .Range("A" & rw).Resize(N).EntireRow.Copy Range("A1")
        End If
        Columns.AutoFit
    Next rw

    .Activate
End With
Application.ScreenUpdating = True

End Sub

Как я могу изменить это?чтобы он спросил, сколько строк заголовков, а затем поместил это количество строк на каждый новый лист?

Answer 1

Вы можете изменить Titles на Long тип данных и снова использовать InputBox, чтобы позволить пользователю вводить число.

Sub SplitDataNrows()

Dim N As Long, H As Long, rw As Long, lr As Long, Titles As Long

If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, _
            "Confirm") = vbNo Then Exit Sub
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
    If N = 0 Then Exit Sub
Titles = InputBox("How many title rows?", "Title Rows",1)

Application.ScreenUpdating = False
With ActiveSheet
    lr = .Range("A" & .Rows.Count).End(xlUp).Row

    For rw = 1 + Titles To lr Step N
        Sheets.Add
        If Titles > 0 Then
            .Range("A1:A" & Titles).EntireRow.Copy Range("A1")
            .Range("A" & rw).Resize(N).EntireRow.Copy Range("A" & 1 + Titles)
        Else
            .Range("A" & rw).Resize(N).EntireRow.Copy Range("A1")
        End If
        Columns.AutoFit
    Next rw

    .Activate
End With
Application.ScreenUpdating = True

End Sub

Вы также можете рассмотреть возможность добавления обработчика ошибок вучетная запись для нечисловых записей от пользователя.