Excel VBA：拆分爲多個表

Question

我創建了一個用戶窗體，允許用戶選擇一個表單來執行宏並輸入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 

另外修改下面一行來計算「天花板」值：

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 

試試！