Split a Worksheet into Tabs or New Workbooks

I have a spreadsheet which has several thousand rows. I need to be able to split it into either, individual tabs within the same workbook or into individual workbooks, based on the change in a specified column, which can ideally be specified by the user using a text entry dialogue (although that last bit would be the icing on the cake).

I've attached a simplified sample.

On the 'All' tab, every time there is a change in Column B, I need to 'copy' all the rows until the next change in Column B, and put them either in a new sheet in the same workbook or into seperate individual workbooks. I would need each new tab of the workbook to include the same header row (or rows) and for the same formating (column widths, colour etc) to be maintained.

I've put the expected results in Sheets 2 through 9, to show what I'm trying to achieve.

Is this possible to do?

Many thanks

Maybe:

Sub hangman()
Dim ws As Worksheet
Dim rcell As Range
Set ws = ActiveSheet
    ws.Range("B3").Select
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
For Each rcell In ws.Range("B2:B" & ActiveSheet.UsedRange.Rows.Count)
    If Right(rcell, 5) = "Total" Then
    
        Range(rcell.Offset(-5, -1), rcell.Offset(-2, 2)).Copy
        Sheets.Add
        Range("A2").Select
        ActiveSheet.Paste
        ActiveSheet.Range("A1").EntireRow.Value = ws.Range("A1").EntireRow.Value
        ws.Rows("1:1").Copy
        ActiveSheet.Rows("1:1").PasteSpecial Paste:=xlPasteFormats
     End If
     ws.Activate
Next rcell
ws.Range("A2").Select
Selection.RemoveSubtotal
ws.Move Before:=Sheets(1)
End Sub

Hi John,

This is working perfectly, although there is one small odd thing happening. On the 7th sheet generated using the sample I posted, it has inserted 'Durham Total #REF!' in Row 2! Not sure where that comes from, any ideas?

Many thanks

Sorry I assumed each location would have 5 rows(is that correct?). Devon has 4. That's what caused the error in Sheets7 and Sheet8 also.

Ah, in the actual main spreadsheet, the number of rows will vary wildly, anywhere between 1 and a few hundred, (my sample was maybe slightly too simplistic), so this would need to be able to account for varying numbers of rows, is that possible to achieve?

The other thing I ideally need to do is to add a total to Column D on each new tab (ideally with the cell, formatted in the same way as the header row), with a blank row between the last entry and the total. I tried adding

        sAddColumnD = "=SUM(D2:D" & x & ")"
        objExcel.Range("D" & x + 2) = sAddColumnD

before the EndIF, but that doesn't work.

Many thanks...

Maybe:

Sub hangman2()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim Y As String

Set ws = ActiveSheet
    ws.Range("B3").Select
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ws.Range("B3").Select
Do Until ActiveCell = ""
Do Until Right(ActiveCell, 5) = "Total"
    ActiveCell.Offset(1).Select
Loop

Y = Left(ActiveCell, 5)
ws.Cells.Find(What:="*" & Y & "*", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Activate
        Set ws2 = Sheets.Add
        ws2.Range("A1").EntireRow.Value = ws.Range("A1").EntireRow.Value
        ws.Rows("1:1").Copy
        ws2.Rows("1:1").PasteSpecial Paste:=xlPasteFormats
     ws.Activate
     Do Until Left(ActiveCell, 5) <> Y
        Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, 2)).Copy ws2.Range("A" & Rows.Count).End(3)(2)
        ActiveCell.Offset(1).Select
     Loop
Loop

ws.Range("A2").RemoveSubtotal
ws.Move Before:=Sheets(1)
End Sub

Hi John,

That works really well, many thanks. If I wanted to insert a blank row between the last row of data and the total on each sheet, is that possible to do?

Try:

Sub hangman2()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim Y As String

Set ws = ActiveSheet
    ws.Range("B3").Select
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ws.Range("B3").Select
Do Until ActiveCell = ""
Do Until Right(ActiveCell, 5) = "Total"
    ActiveCell.Offset(1).Select
Loop

Y = Left(ActiveCell, 5)
ws.Cells.Find(What:="*" & Y & "*", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Activate
        Set ws2 = Sheets.Add
        ws2.Range("A1").EntireRow.Value = ws.Range("A1").EntireRow.Value
        ws.Rows("1:1").Copy
        ws2.Rows("1:1").PasteSpecial Paste:=xlPasteFormats
     ws.Activate
     Do Until Left(ActiveCell, 5) <> Y
        Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, 2)).Copy ws2.Range("A" & Rows.Count).End(3)(2)
        ActiveCell.Offset(1).Select
     Loop
     ws2.Activate
     ws2.Range("B" & ws2.UsedRange.Rows.Count).EntireRow.Insert xlDown
     ws.Activate
Loop

ws.Range("A2").RemoveSubtotal
ws.Move Before:=Sheets(1)
End Sub

That goes slightly weird again on sheets 2 and 6...


Is it possible to also make the total figure bold in the same way as the text in the total line? Sorry, my knowledge of VBA is very limited.

I'm sorry I can't duplicate any errors on Sheets 2 and 6.

For the bold issue try:

Sub hangman2()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim Y As String

Set ws = ActiveSheet
    ws.Range("B3").Select
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ws.Range("B3").Select
Do Until ActiveCell = ""
Do Until Right(ActiveCell, 5) = "Total"
    ActiveCell.Offset(1).Select
Loop

Y = Left(ActiveCell, 5)
ws.Cells.Find(What:="*" & Y & "*", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Activate
        Set ws2 = Sheets.Add
        ws2.Range("A1").EntireRow.Value = ws.Range("A1").EntireRow.Value
        ws.Rows("1:1").Copy
        ws2.Rows("1:1").PasteSpecial Paste:=xlPasteFormats
     ws.Activate
     Do Until Left(ActiveCell, 5) <> Y
        Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, 2)).Copy ws2.Range("A" & Rows.Count).End(3)(2)
        ActiveCell.Offset(1).Select
     Loop
     ws2.Activate
     ws2.Range("B" & ws2.UsedRange.Rows.Count).EntireRow.Insert xlDown
     ws2.Range("D" & ws2.UsedRange.Rows.Count).Font.Bold = True
     ws.Activate
Loop

ws.Range("A2").RemoveSubtotal
ws.Move Before:=Sheets(1)
End Sub

Hi John,

I ran the latest version of the code (see attached), which has fixed the bold part, but there is that same issue on the last sheet now as before and the columns widths no longer work...

Hi John,

I ran the latest version of the code (see attached), which has fixed the bold part, but there is that same issue on the last sheet now as before and the column widths no longer work...

Try:

Sub hangman2()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim Y As String

Set ws = ActiveSheet
    ws.Range("B3").Select
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ws.Range("B3").Select
Do Until ActiveCell = ""
Do Until Right(ActiveCell, 5) = "Total"
    ActiveCell.Offset(1).Select
Loop

Y = Left(ActiveCell, 5)
ws.Cells.Find(What:="*" & Y & "*", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Activate
        Set ws2 = Sheets.Add
        ws2.Range("A1").EntireRow.Value = ws.Range("A1").EntireRow.Value
        ws.Rows("1:1").Copy
        ws2.Rows("1:1").PasteSpecial Paste:=xlPasteFormats
     ws.Activate
     Do Until Left(ActiveCell, 5) <> Y
        Range(ActiveCell.Offset(, -1), ActiveCell.Offset(, 2)).Copy ws2.Range("A" & Rows.Count).End(3)(2)
        ActiveCell.Offset(1).Select
     Loop
     ws2.Activate
     ws2.Range("B" & ws2.UsedRange.Rows.Count).EntireRow.Insert xlDown
     ws2.Range("D" & ws2.UsedRange.Rows.Count).Font.Bold = True
     ws2.Columns("A:A").ColumnWidth = 8.43
     ws2.Columns("B:B").ColumnWidth = 31.14
     ws2.Columns("C:C").ColumnWidth = 31.14
     ws2.Columns("D:D").ColumnWidth = 10.2
     ws.Activate
Loop

ws.Range("A2").RemoveSubtotal
ws.Move Before:=Sheets(1)
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
End Sub