VBA code to split worksheet with multiple sheets

shell2133

New Member
Joined
Jan 21, 2022
Messages
26
Office Version
  1. 2016
Platform
  1. Windows
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!
 

Attachments

  • Assignment tab.PNG
    Assignment tab.PNG
    145 KB · Views: 17
  • position tab.PNG
    position tab.PNG
    89.1 KB · Views: 17
Try:
VBA Code:
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
 
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
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.
 
Upvote 0
Please upload a file which shows the desired end result for both sheets for Locality F1.
 
Upvote 0
Try:
VBA Code:
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
 
Upvote 0
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
 
Upvote 0
That is strange. I don't get that error. Try:
VBA Code:
Sheets("Sheet2").Range("A1").PasteSpecial
 
Upvote 0
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
 
Upvote 0
Run the macro one line at a time using the F8 key and stop after the line
VBA Code:
Workbooks.Add
Check the newly opened workbook. How many sheets in total does this workbook have? It should have three sheets.
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,040
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top