Excel VBA:拆分到多个工作表

Question

我正在创建一个UserForm，它允许用户选择要执行宏的工作表，并输入X数量的行数，最终目标是将选定的工作表按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

修改有问题的代码片段，如下所示：

 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

另外，修改下面这行代码来计算"Ceiling“值：

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

用于计算doMath值的模拟VBA "Ceiling“函数也可以写成：

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

注意:在这个特定的示例中，您可以交替使用VBA和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

试试看！