Excel VBA: Split to Multiple Sheets

Question

I'm creating a UserForm that allows the user to select a sheet to perform the macro on and enter in X amount of rows in which the ultimate goal is to split the selected sheet into multiple sheets by X amount of rows.

Code:

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

The last section of code is where I need help because I can't seem to figure out how to do it properly..

The code currently loops through the newly added sheets and "pastes" in the same rows. For example, if the sheet selected has 1000 rows (rowCount), and rowEntered is 500, then it would create 2 new sheets. Rows 1-500 should go in New-1 and Rows 501-1000 should go into New-2. How can I achieve this?

Answer 1

Modify that problematic code snippet as shown below:

 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

Also modify the following line to calculate the "Ceiling" value:

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

The simulated VBA "Ceiling" function used to calculate the doMath value could be also written as:

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

Note: In this particular sample, you can use VBA INT and FIX functions interchangeably.

Hope this will help.

Answer 2

Check below code. Please, read comments.

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

Try!