Excel VBA：拆分为多个表格

我创build一个用户窗体，允许用户select一个工作表来执行macros，并inputX行的数量，其中最终目标是将所选工作表分成多个工作表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，那么它将创build2个新工作表。 第1-500行应该进入New-1行，501-1000行应该进入New-2。 我怎样才能做到这一点？

Answer 1

检查下面的代码。 请阅读评论。

 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 

尝试！

Answer 2

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

  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) 

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

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

注意：在这个特定的示例中，可以互换使用VBA INT和FIX函数。

希望这会有所帮助。