Excel VBA: Split to Multiple Sheets - vba

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

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!

Answer 2

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.