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]

Still validating the data but so far that is perfect.

Didn't dawn on me that maybe I needed less.

Thanks Fluff, you have helped so much

 

[Fluff]

You're welcome & thanks for the feedback

 

[rezacs]

Guess I have one more situation I'm trying to work with.
Same as previous except I need to select specific items to filter.
For instance I want to create a new tab as before but i want to filter for specific 4 users to display in that tab, and not put them in individual tabs (user1, user2, user5, user8)

 

[Fluff]

Will it always be the same 4 users?

 

[rezacs]

Yes

 

[Fluff]

Try

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
   Dim Ary As Variant
   
   Ary = Array("User1", "User1", "User3", "User4")
   Set Ws = Sheets(1)
   If Ws.FilterMode Then Ws.ShowAllData
   Sheets.Add(, Sheets(Sheets.Count)).Name = "4users"
   Ws.Range("a5").AutoFilter 1, Ary, xlFilterValues
   Ws.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).EntireRow.Copy ActiveSheet.Range("A5")
   Ws.ShowAllData
End Sub

 

[rezacs]

Almost. The new sheet is created with the name provided. However, the actual sheet remains blank, no data seems to copy.

A couple things to clarify, the names being filtered are full names "Firstname Lasname", if that matters.

Also the names i want to filter for on are under column C.

The filtered header row is on row 5 and then the data starts on row 6.

As before there are various formatted and merged cells that need to retain their formatting in rows 1-5.

 

[Fluff]

To filter on col c use

Ws.Range("a5").AutoFilter 3, Ary, xlFilterValues

also the values in the array must match the values you are filtering for.

 

[rezacs]

Looking better, data is copying now into the newly created sheet, but none of the header data or formatting in rows 1-5 are carrying over.

Are we able to make it create a copy of the sheet1 tab and rename it, filter out the names i'm looking for in the array and delete the rest of the data?

Playing around I can get it to filter out one of the values typed in directly, but can't get it to filter out an array of values so is it not possible?

 

[Fluff]

Try

Sub FilterCopy()
   Dim cl As Range
   Dim Ws As Worksheet
   Dim Ary As Variant
   
   Ary = Array("User1", "User1", "User3", "User4")
   Set Ws = Sheets(1)
   If Ws.FilterMode Then Ws.ShowAllData
   Sheets.Add(, Sheets(Sheets.Count)).Name = "4users"
   Ws.Range("a5").AutoFilter 1, Ary, xlFilterValues
   Ws.Cells.SpecialCells(xlVisible).Copy ActiveSheet.Range("A5")
   Ws.ShowAllData
End Sub

You can only filter for 2 values if you use "not equal to".