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

変更することを問題のコードスニペットを以下に示すとおり計算するために使用

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

模擬VBA「天井」機能：

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の値は、次のようにも書くことができます。

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 

試してみてください！