Excel VBA: разделение на несколько листов

Question

Я создаю UserForm, который позволяет пользователю выбирать лист для выполнения макроса и вводить в X количество строк, в которых конечной целью является разделение выбранного листа на несколько листов по Х количество строк.

Код:

Dim rowCount As Long 
Dim rowEntered As Long 
Dim doMath As Long 

rowCount = Sheets(Me.ComboBox1.Value).Cells(Rows.Count, "A").End(xlUp).Row 'Count Number of Rows in selected Sheet 
rowEntered = Val(Me.TextBox1.Value) 'User enters X amount 

If rowCount < rowEntered Then 
    MsgBox "Enter in another number" 
Else 
doMath = (rowCount/rowEntered) 
For i = 1 to doMath 
Sheets.Add.name = "New-" & i 
Next i 

'Help!! 
For i= 1 to doMath 
Sheets("New-" & i).Rows("1:" & rowEntered).Value = Sheets(Me.ComboBox1.Value).Rows("1:" & rowEntered).Value 
Next i 
End If 

Последняя часть кода, где мне нужна помощь, потому что я не могу понять, как сделать это правильно ..

в настоящее время код перебирает вновь добавлены листы и «пасты» в тех же строках. Например, если выбранный лист имеет 1000 строк (rowCount), а rowEntered - 500, тогда он создаст 2 новых листа. Строки 1-500 должны идти в New-1, а строки 501-1000 должны идти в New-2. Как я могу это достичь?

Answer 1

Modify, что проблемный фрагмент кода, как показано ниже:

For i = 1 To doMath 
    Sheets("New-" & i).Range("1:" & rowEntered).Value = Sheets(Me.ComboBox1.Value).Range((i - 1) * rowEntered + 1 & ":" & i * rowEntered).Value 
Next i 

также изменить следующую строку, чтобы вычислить «потолок» значение:

doMath = Fix(rowCount/rowEntered) + IIf(rowCount Mod rowEntered > 0, 1, 0) 

Функция моделируемого VBA «потолок», используемая для расчета Значение по умолчанию: doMath значение также может быть записано как:

doMath = Int(RowCount/rowEntered) + Abs(RowCount Mod rowEntered > 0) 

Примечание. В этом конкретном примере вы можете использовать функции VBA INT и FIX взаимозаменяемыми функциями.

Надеюсь, это поможет.

Answer 2

Проверьте код. Пожалуйста, прочитайте комментарии.

Option Explicit 

'this procedure fires up with button click 
Sub Button1_Click() 

    SplitDataToSheets Me.ComboBox1.Value, CInt(Me.TextBox1.Value) 

End Sub 

'this is main procedure 
Sub SplitDataToSheets(ByVal shName As String, ByVal rowAmount As Long) 
Dim srcWsh As Worksheet, dstWsh As Worksheet 
Dim rowCount As Long, sheetsToCreate As Long 
Dim i As Integer, j As Long 

'handle events 
On Error GoTo Err_SplitDataToSheets 

'define source worksheet 
Set srcWsh = ThisWorkbook.Worksheets(shName) 
'Count Number of Rows in selected Sheet 
rowCount = srcWsh.Range("A" & srcWsh.Rows.Count).End(xlUp).Row 
'calculate the number of sheets to create 
sheetsToCreate = CInt(rowCount/rowAmount) + IIf(rowCount Mod rowAmount > 0, 1, 0) 

If rowCount < rowAmount Then 
    If MsgBox("The number of rows in source sheet is less then number of " & vbCr & vbCr & _ 
       "The rest of message", vbQuestion + vbYesNo + vbDefaultButton2, "Question..") = vbYes Then GoTo Exit_SplitDataToSheets 
End If 
' 
j = 0 
'create the number of sheets in a loop 
For i = 1 To sheetsToCreate 
    'check if sheet exists 
    If SheetExists(ThisWorkbook, "New-" & i) Then 
     'clear entire sheet 
     Set dstWsh = ThisWorkbook.Worksheets("New-" & i) 
     dstWsh.Cells.Delete Shift:=xlShiftUp 
    Else 
     'add new sheet 
     ThisWorkbook.Worksheets.Add After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) 
     Set dstWsh = ActiveSheet 
     dstWsh.Name = "New-" & i 
    End If 
    'copy data 
    srcWsh.Range("A" & j + 1 & ":A" & j + rowAmount).EntireRow.Copy dstWsh.Range("A1") 
    'increase a "counter" 
    j = j + rowAmount 
Next i 

'exit sub-procedure 
Exit_SplitDataToSheets: 
    On Error Resume Next 
    Set srcWsh = Nothing 
    Set dstWsh = Nothing 
    Exit Sub 

'error sub-procedure 
Err_SplitDataToSheets: 
    MsgBox Err.Description, vbExclamation, Err.Number 
    Resume Exit_SplitDataToSheets 

End Sub 

'function to check if sheet exists 
Function SheetExists(ByVal wbk As Workbook, ByVal wshName As String) As Boolean 
Dim bRetVal As Boolean 
Dim wsh As Worksheet 

On Error Resume Next 
Set wsh = wbk.Worksheets(wshName) 

bRetVal = (Err.Number = 0) 
If bRetVal Then Err.Clear 

SheetExists = bRetVal 

End Function 

Попробуйте!