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?

Use range instead? Create range variables that holds the rows then drop them. — findwindow
– findwindow, Commented Mar 25, 2016 at 20:48

Maciej Los · Accepted Answer · 2016-03-25 21:42:33Z

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!

Alexander Bell · Accepted Answer · 2016-03-25 22:13:18Z

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.

Collectives™ on Stack Overflow

Excel VBA: Split to Multiple Sheets

2 Answers 2

Comments

Comments

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Comments

Comments

Related