VBA Split One Worksheet Into Multiple Workbooks and Retain Formatting

[rezacs]

I'm fairly new to VBA. I'm trying to split a worksheet into multiple workbooks based on the value in Column A. I can get the code to work slightly using the some older code I found below but it stalls on a couple issues:
1. The sheet I have has 4 rows of titles, even with the code identifying those title rows it fails with a Run-time error 1004 saying the command requires at least two rows of data source. I can work around this by deleting the main title in A1 as A2 and A3 are blank cells so it then picks up at A4 where the row header and data starts.

2. If I delete the title in A1 and run it, the code then fails with another Run-time error 1004 but this time saying it can't do that to a merged cell. This is when it reaches the"'customize this section as needed for copy/paste targets" section where it is trying to copy the titles section to the new worksheet failing because there are merged cells it is trying to copy. Is there a way around this so they can stay merged and keep the output the same on the new sheet?

3. If i remove the main title in A1 or Delete the first 2 rows and get rid of the merged formatting in the title rows and then run it on that it fails on the second part of the section in point 2 above and I notice the title output is messed up. Seems the title rows in general are giving me most of my trouble, but they are needed.

4. One time I was able to get it to create sheets for about 18 branches but then failed when the branch jumped in order from 18 to 21.

5. One other change I need is for this to split out into separate workbooks for each branch and rename it so the branch number is included in the filename rather than create new sheets in the existing workbook. On top of all of this I need it to retain formatting from the original document.

Is it possible to simply replicate the main workbook, rename based on branch ID (from "2018 Credit Planning - AllBranches.xlsx" to "2018 Credit Planning - Br 01.xlsx") and then just copy or retain the relevant branch information?

Is any of this possible or just too complicated to do using VBA code?

Below is a link to an example of the document:
https://1drv.ms/x/s!AuRLozE5HIbIiJsHXmvEsXrcp0umdw

Option Explicit


Sub ParseItems()
'Jerry Beaucaire  (11/11/2009)
'Based on selected column, data is filtered to individual sheets
'Creates sheets and sorts sheets alphabetically in workbook
'6/10/2010 - added check to abort if only one value in vCol
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim WS As Worksheet, MyArr As Variant, vTitles As String, Oops As Boolean


Application.ScreenUpdating = False


'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1
 
'Sheet with data in it, change to suit
   Set WS = Sheets("18CrdPlanning_Br")


'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:AB4"
   
'Spot bottom row of data
   LR = WS.Cells(WS.Rows.Count, vCol).End(xlUp).Row


'Get a temporary list of unique values from column A
    WS.Columns(vCol).SpecialCells(xlConstants).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=WS.Range("EE1"), Unique:=True


'Sort the temporary list
    WS.Columns("EE:EE").Sort Key1:=WS.Range("EE2"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal


'Check for more than one value in list
    If WS.Range("EE" & Rows.Count).End(xlUp).Row > 2 Then


'Put list into an array for looping
'(values cannot be the result of formulas, must be constants)
        MyArr = Application.WorksheetFunction.Transpose(WS.Range("EE2:EE" _
            & Rows.Count).SpecialCells(xlCellTypeConstants))


'clear temporary worksheet list
        WS.Range("EE:EE").Clear


    Else
        WS.Range("EE:EE").Clear
        Oops = True
        GoTo ErrorExit
    End If
    
'Turn on the autofilter, one column only is all that is needed
    WS.Range(vTitles).AutoFilter


'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        WS.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
    
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm)
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm)).Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(Itm)).Cells.Clear
        End If


    'customize this section as needed for copy/paste targets
        WS.Range("A" & WS.Range(vTitles).Resize(1, 1).Row & ":A" & LR) _
            .EntireRow.Copy Sheets(MyArr(Itm) & "").Range("A1")


        
        WS.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr(Itm)) _
            .Range("A" & Rows.Count).End(xlUp).Row - 1
        Sheets(MyArr(Itm)).Columns.AutoFit
    Next Itm
    
'Cleanup
    WS.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"


ErrorExit:
    If Oops Then MsgBox "Only one value found, aborting parse process..."
    Application.ScreenUpdating = True
End Sub

 

[rezacs]

Couldn't see a way to edit my original post.

Seems the link to the sheet didn't work so here is an updated one:
https://1drv.ms/x/s!AuRLozE5HIbIiJsIkOTo81JpcWutXw

 

[Fluff]

Hi & welcome to MrExcel.
Try

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("18CrdPlanning_Br")
   If Ws.FilterMode Then Ws.ShowAllData
   With CreateObject("scripting.dictionary")
      For Each cl In Ws.Range("A5", Ws.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(cl.Value) Then
            .Add cl.Value, Nothing
            Ws.copy
            Range("a4").AutoFilter 1, "<>" & cl.Value
            Range("A5:A200").SpecialCells(xlVisible).EntireRow.Delete
            ActiveSheet.ShowAllData
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\2018 Credit Planning - Br " & cl.Value & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next cl
   End With
End Sub

 

[rezacs]

Thank you Fluff, that worked great.

Just 2 questions to see if there is a way to work with a couple aesthetic items:

1. Is it possible to update the Set Ws line so that it can adjust for changes to the worksheet name, for example if it is changed to "19CrdPlanning_Br" next year or would we need update that in the code each time it is changed? We can probably give the actual worksheet name a more generic name, but just wanted to see if it is possible.

2. When the new worksheet is created it is not retaining the cell fill colors from the original sheet in T3:AB4, it is giving it shades of gray instead of retaining the shades of brown/yellow in the original. Is there a way to retain this formatting in this area in the new copies?

Thanks

 

[Fluff]

This should retain the colours

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets("18CrdPlanning_Br")
   If Ws.FilterMode Then Ws.ShowAllData
   With CreateObject("scripting.dictionary")
      For Each cl In Ws.Range("A5", Ws.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(cl.Value) Then
            .Add cl.Value, Nothing
            Ws.Copy
            ActiveWorkbook.Theme.ThemeColorScheme.Load ( _
               "C:\Program Files\Microsoft Office 15\Root\Document Themes 15\Theme Colors\Office 2007 - 2010.xml")
            Range("a4").AutoFilter 1, "<>" & cl.Value
            Range("A5:A200").SpecialCells(xlVisible).EntireRow.Delete
            ActiveSheet.ShowAllData
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\2018 Credit Planning - Br " & cl.Value & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next cl
   End With
End Sub

Regarding the sheet name (assuming that there will always be more than one sheet in the file) You could enter the sheet name in a cell (on a sheet whose name remains the same) somewhere & point the code to that

 

[rezacs]

That worked, I did have to update the path since apparently we are using 32-bit 2016 version which would be my main worry if someone runs this on a different version. Would it be beneficial to add something to test it and if it doesn't find that path on their computer then ignore the theme load? Or maybe a more dynamic way to find that theme xml file without a full path? Ideally my hope is we can set this to run on one machine or virtual machine.

Regarding the worksheet name we will only always have one tab in this workbook. I made a slight adjustment to the code, wanted to see if this is feasible since we always create this particular document within the year it is being sent for. It seems to work but wanted to make sure i'm not doing something that could cause problems.

One other thing I found after using it and understanding the code better is at the line that states "Range ("A5:A15000") .SpecialCells (xlVisible) .EntireRow .Delete" I needed to add the extended range beyond 200 as it was failing when looking at the full dataset as it currently extends to roughly 13500 rows. Is there a way to allow this to adjust dynamically if the data goes beyond 15000 rows? Or am I safe to set the end of the range to A30000 without causing any problems?

Thanks again, this has been quite educational.

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets(Format(Date, "YY") & "CrdPlanning_Br")
   If Ws.FilterMode Then Ws.ShowAllData
   With CreateObject("scripting.dictionary")
      For Each cl In Ws.Range("A5", Ws.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(cl.Value) Then
            .Add cl.Value, Nothing
            Ws.Copy
            ActiveWorkbook.Theme.ThemeColorScheme.Load ( _
               "C:\Program Files (x86)\Microsoft Office\Document Themes 16\Theme Colors\Office 2007 - 2010.xml")
            Range("a4").AutoFilter 1, "<>" & cl.Value
            Range("A5:A15000").SpecialCells(xlVisible).EntireRow.Delete
            ActiveSheet.ShowAllData
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Date, "YYYY") & " Credit Planning - Br " & cl.Value & ".xlsx", 51
            ActiveWorkbook.Close False
         End If
      Next cl
   End With
End Sub

 

[Fluff]

As you only have one sheet in the workbook you can use

 Set Ws = Sheets(1)

And you can use this to make the Deletion range dynamic

            ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).EntireRow.Delete

I've never tried copying themes before, so not sure if there's a better way or not.

 

[rezacs]

Those changes worked great.
Thank you for all your help.

I did a little more digging and did find one more solution to the color themes.

Set an initial statement to save the current color scheme of the document:

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">[COLOR=#303336][FONT=inherit]ActiveWorkbook[/FONT][/COLOR][COLOR=#303336][FONT=inherit].[/FONT][/COLOR][COLOR=#303336][FONT=inherit]Theme[/FONT][/COLOR][COLOR=#303336][FONT=inherit].[/FONT][/COLOR][COLOR=#303336][FONT=inherit]ThemeColorScheme[/FONT][/COLOR][COLOR=#303336][FONT=inherit].[/FONT][/COLOR][COLOR=#303336][FONT=inherit]Save[/FONT][/COLOR][COLOR=#303336][FONT=inherit]([/FONT][/COLOR][COLOR=#7D2727][FONT=inherit]"C:\myThemeColorScheme.xml"[/FONT][/COLOR][COLOR=#303336][FONT=inherit])[/FONT][/COLOR]</code>

Then set another after the copy to load the color scheme into the new document:

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">[COLOR=#303336][FONT=inherit]ActiveWorkbook[/FONT][/COLOR][COLOR=#303336][FONT=inherit].[/FONT][/COLOR][COLOR=#303336][FONT=inherit]Theme[/FONT][/COLOR][COLOR=#303336][FONT=inherit].[/FONT][/COLOR][COLOR=#303336][FONT=inherit]ThemeColorScheme[/FONT][/COLOR][COLOR=#303336][FONT=inherit].[/FONT][/COLOR][COLOR=#303336][FONT=inherit]Load[/FONT][/COLOR][COLOR=#303336][FONT=inherit]([/FONT][/COLOR][COLOR=#7D2727][FONT=inherit]"C:\myThemeColorScheme.xml"[/FONT][/COLOR][COLOR=#303336][FONT=inherit])[/FONT][/COLOR]</code>

 

[rezacs]

Adding on to this I have a new requirement.
I still have the same issue as I mentioned originally where i need to keep formatting from the parent sheet to the new sheets and I have multiple rows of information above the header row.
However instead of splitting it out to new workbooks I need to split it out to new worksheets within the current workbook.

I have modified the script as follows and I can get it to create new worksheets named with the different values listed in column A (13 values) but the data will not copy into those new worksheets, they remain empty.

The text in red is what I changed to create the new worksheets and name them.

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets(1)
   ActiveWorkbook.Theme.ThemeColorScheme.Save ("C:\Users\Public\myThemeColorScheme.xml")
   If Ws.FilterMode Then Ws.ShowAllData
   With CreateObject("scripting.dictionary")
      For Each cl In Ws.Range("A6", Ws.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(cl.Value) Then
            .Add cl.Value, Nothing
            Ws.Copy
            ActiveWorkbook.Theme.ThemeColorScheme.Load ("C:\Users\Public\myThemeColorScheme.xml")
            Range("a5").AutoFilter 1, "<>" & cl.Value
            ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).EntireRow.Delete
            ActiveSheet.ShowAllData
[COLOR=#ff0000]            ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = cl.Value[/COLOR]
            ActiveWorkbook.Close False
         End If
      Next cl
   End With
End Sub

Is it possible to do what I'm requesting.

This works perfectly to split out the data to new workbooks, I would think it is something simple that i'm missing...or maybe not.

 

[Fluff]

Try

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
   
   Set Ws = Sheets(1)
   If Ws.FilterMode Then Ws.ShowAllData
   With CreateObject("scripting.dictionary")
      For Each cl In Ws.Range("A6", Ws.Range("A" & Rows.Count).End(xlUp))
         If Not .Exists(cl.Value) Then
            .Add cl.Value, Nothing
            Ws.Copy , Sheets(Sheets.Count)
            ActiveSheet.Name = cl.Value
            ActiveSheetRange("a5").AutoFilter 1, "<>" & cl.Value
            ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).EntireRow.Delete
            ActiveSheet.ShowAllData
         End If
      Next cl
   End With
End Sub