Create new Worksheet for each change in Column B

[philwilliams80]

It seems that a split existing data to new worksheets macro is a fairly common request, however from my searching online, I haven't managed to find one that satisfies what I need, and my VBA skills are not quite good enough to write this myself, or successfully adapt an existing version from the ones I have viewed so far, so I would be very grateful if someone had some existing code they could share that can be adapted.

The worksheet I need splitting stretches from column A to AV (perhaps further in future), and I would like the splitting to start from row 8, with row 6 being the headings and row 7 being blank. If possible, I would like the headings copied across to each new worksheet, as well as all existing formats.

Ideally the names of the new worksheets should be the same as the data in column B that the split is created on, however some of these headings have too many characters to fit into the worksheet name. Can this be managed without manual editing?

There are other existing worksheets in the workbook. These should remain.

Aside from these, I think it should be a pretty simple request for someone with a greater knowledge than me!

Many thanks in advance.

Ps. I can share a workbook if this is required but will have to create a 'non-sensitive' version for online posting. Let me know.

[JasperD]

Do your p.s.

[philwilliams80]

Do your p.s.

Apologies for the delay.

I have attached the file that needs to be split via changes in column B - it has evolved and the new worksheets can be created as per column B or C. C is just a shorter version of column B to avoid the issue with the number of characters (if required).

I need the formatting to be copied across so that the grouped cells can be minimized OR a new file created with formulas changed to values and the minimised columns can be deleted for distribution.

The attachment was too big in its proper state so I have deleted the two additional tabs which have data that fulfils the lookup formualas. The macro could do with working taking into account that these will be there.

I'm very grateful for any advice or help that can be given.

The code I posted earlier is now falling down very early on, and I'm unsure how to progress.

Thanks

[arlu1201]

However some of these headings have too many characters to fit into the worksheet name.

What do you want to do in this case?

[philwilliams80]

For the time being I have manually created a column with the formula =LEFT(C8, SEARCH("-",C8)-1) which is trimming it down to a more usable level.

I have also managed to find some code which is working to a point:

Option Explicit

Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
Dim HeaderRow As Long

    Set wsAll = Worksheets("STAFF ESTABLISHMENT") ' change All to the name of the worksheet the existing data is on
    
    ' change to whatever row the headers are in
    HeaderRow = 6
    
    wsAll.Range("B1").Value = "Field1"
    
    LastRow = wsAll.Range("B" & Rows.Count).End(xlUp).Row
    
    Set wsCrit = Worksheets.Add
    
    ' column A has the criteria eg project ref
    wsAll.Range("B" & HeaderRow & ":B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("B1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("B" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        Set wsNew = Worksheets.Add
        wsNew.name = wsCrit.Range("B2")
        wsAll.Rows(HeaderRow & ":" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("B1:B2"), _
         CopyToRange:=wsNew.Range("A1"), Unique:=False
         wsNew.Range("B1").Value = ""
        wsCrit.Rows(2).Delete
        
    Next I
    
    wsAll.Range("B1").Value = ""
    
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

The issue I have now, is that my original worksheet has multiple grouped hidden columns, and the new sheets that are being created are not carrying this format over. Is there anything I can do that will fix this?

Thanks

[arlu1201]

If you need to hide the columns in each sheet, would it be the same columns that would be hidden / deleted for all sheets?

[philwilliams80]

If you need to hide the columns in each sheet, would it be the same columns that would be hidden / deleted for all sheets?

Hi arlu1201, many thanks for replying. It would be the same columns.

I have actually found a solution that works - i.e. some existing code, and then added some code of my own to make it work in the specific way I need. It's probably crude, but it seems to do the job. Obviously if there are glaring errors or inefficiencies then I would be glad of any advice.

Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
    Dim My_Range As Range
    Dim FieldNum As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim ws2 As Worksheet
    Dim Lrow As Long
    Dim cell As Range
    Dim CCount As Long
    Dim WSNew As Worksheet
    Dim ErrNum As Long
    
        Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets(Array("PAY REPORT", "STATEMENT REC")).Select
    Sheets("STATEMENT REC").Activate
    Application.CutCopyMode = False
    ActiveWindow.SelectedSheets.Delete
    Cells.Select
    Selection.EntireColumn.Hidden = False
    'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
    'and the header of the first column, D is the last column in the filter range.
    'You can also add the sheet name to the code like this :
    'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
    'No need that the sheet is active then when you run the macro when you use this.
    Set My_Range = Range("A4:AT2000") '  & LastRow(ActiveSheet))
    My_Range.Parent.Select

    If ActiveWorkbook.ProtectStructure = True Or _
       My_Range.Parent.ProtectContents = True Then
        MsgBox "Sorry, not working when the workbook or worksheet is protected", _
               vbOKOnly, "Copy to new worksheet"
        Exit Sub
    End If

    'This example filters on the first column in the range(change the field if needed)
    'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
    FieldNum = 3 ' I changed this to 3 for column C

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Range.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
             Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            'Check if there are no more then 8192 areas(limit of areas)
            CCount = 0
            On Error Resume Next
            CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
                     .Areas(1).Cells.Count
            On Error GoTo 0
            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
            Else
                'Add a new worksheet
                Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.name = cell.Value
                If Err.Number > 0 Then
                    ErrNum = ErrNum + 1
                    WSNew.name = "Error_" & Format(ErrNum, "0000")
                    Err.Clear
                End If
                On Error GoTo 0

                'Copy the visible data to the new worksheet
                My_Range.SpecialCells(xlCellTypeVisible).Copy
                With WSNew.Range("A1")
                    ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                    ' Remove this line if you use Excel 97
                    .PasteSpecial Paste:=8
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                    .Select
                End With
            End If

            'Show all data in the range
            My_Range.AutoFilter Field:=FieldNum

        Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    If ErrNum > 0 Then
        MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
             & vbNewLine & "There are characters in the name that are not allowed" _
             & vbNewLine & "in a sheet name or the worksheet already exist."
    End If

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    My_Range.Parent.Select
    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
Dim iwsCount As Integer
Dim I As Integer

' Set 'wsCount equal to the number of worksheets in the active workbook
iwsCount = ActiveWorkbook.Worksheets.Count

' Begin the Loop
For I = 1 To iwsCount
Sheets(I).Select
With ActiveSheet.PageSetup
 
    
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
        .Order = xlDownThenOver
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1

 
        Range("A:A,C:E,I:N,Q:T,Z:AA,AD:AI,AM:AS").Select
        Selection.EntireColumn.Hidden = True
        End With

Next I

 

End Sub

[arlu1201]

If its working for you, its fine. I wouldnt want to interfere with it, since its neatly commented and working.

If your issue is solved, please mark your thread as solved.