VBA code to split worksheet with multiple sheets

[shell2133]

Hello everyone. I would like to split a worksheet which has two sheets called "Position and "Assignment" at each change in column E, "Org L5", on both tabs, so create a new sheet with a position and assignment tab for each of the different Org L5s, preserving the headers and formulas etc. The headers on the Position tab are in A1:Y3, on the Assignment tab they're in A1:U1. I want to name the new sheets as per column E, the Org L5 name. I've done similar for one tab before but not two and I'm also struggling with the header on the first tab with it being in multiple rows. Would anyone know a code for this please? Thanks!

 

[mumps]

Try:

Sub CreateSheets()
    Application.ScreenUpdating = False
    Dim posWS As Worksheett, v As Variant, dic As Object, i As Long, WB As Workbook
    Set WB = ThisWorkbook
    Set posWS = WB.Sheets("Position")
    Set dic = CreateObject("Scripting.Dictionary")
    With posWS
        v = .Range("E4", .Range("E" & .Rows.Count).End(xlUp)).Value
        For i = LBound(v) To UBound(v)
            If Not dic.exists(v(i, 1)) Then
                dic.Add v(i, 1), Nothing
                .Range("A1").CurrentRegion.AutoFilter 5, v(i, 1)
                .AutoFilter.Range.Copy
                Workbooks.Add 1
                Range("A1").PasteSpecial
                ActiveSheet.Name = v(i, 1)
                Columns.AutoFit
                With WB.Sheets("Position")
                    .Range("A1").AutoFilter
                    .Copy Before:=Sheets(1)
                End With
                With ActiveWorkbook
                    Application.DisplayAlerts = False
                    .SaveAs Filename:="C:\Users\shell\Documents\" & v(i, 1), FileFormat:=51
                    .Close False
                    Application.DisplayAlerts = True
                End With
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[shell2133]

Thank you for this but it doesn't appear to be working? The Position tab on the new files still has all the localities data on it and the Assignment tab has been renamed and contains data from the Position tab.

 

[mumps]

Please upload a file which shows the desired end result for both sheets for Locality F1.

 

[shell2133]

STAFF LIST LOC1

 

[mumps]

Try:

Sub CreateWorkbooks()
    Application.ScreenUpdating = False
    Dim posWS As Worksheet, assWS As Worksheet, v As Variant, dic As Object, i As Long, WB As Workbook
    Set WB = ThisWorkbook
    Set posWS = WB.Sheets("Position")
    Set assWS = WB.Sheets("Assignment")
    Set dic = CreateObject("Scripting.Dictionary")
    With posWS
        v = .Range("E4", .Range("E" & .Rows.Count).End(xlUp)).Value
        For i = LBound(v) To UBound(v)
            If Not dic.exists(v(i, 1)) Then
                dic.Add v(i, 1), Nothing
                .Range("A1").CurrentRegion.AutoFilter 5, v(i, 1)
                .AutoFilter.Range.Offset(1).Copy
                Workbooks.Add
                Range("A4").PasteSpecial
                ActiveSheet.Name = "Position"
                .Range("A1").AutoFilter
                .Range("A1:Y3").Copy Range("A1")
                Columns.AutoFit
                With assWS
                    .Range("A1").CurrentRegion.AutoFilter 5, v(i, 1)
                    .AutoFilter.Range.Copy
                    Sheets(2).Range("A1").PasteSpecial
                    Sheets(2).Name = "Assignment"
                End With
                With ActiveWorkbook
                    Application.DisplayAlerts = False
                    .SaveAs Filename:="C:\Users\shell\Documents\" & v(i, 1), FileFormat:=51
                    .Close False
                    Application.DisplayAlerts = True
                End With
            End If
        Next i
    End With
    assWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[shell2133]

I got an error message “Run-time error ‘9’: Subscript out of range”. When I press debug this line is highlighted - Sheets(2).Range("A1").PasteSpecial

 

[mumps]

That is strange. I don't get that error. Try:

Sheets("Sheet2").Range("A1").PasteSpecial

 

[shell2133]

Nope, still getting an error and that line is highlighted. It opens a new sheet named Book1 that only has the Position tab, I don't know if that means anything

 

[mumps]

Run the macro one line at a time using the F8 key and stop after the line

Workbooks.Add

Check the newly opened workbook. How many sheets in total does this workbook have? It should have three sheets.

 

[shell2133]

It only has one sheet, Sheet1.