Split Book Macro with multiple tabs

[cmschmitz24]

Hello,

I need help with enhancing a split book macro. I have the basic macro that will split the workbook based on data in a specific column, however my workbook has multiple tabs and the data won't all be the "same". I need the split book macro to split based on the data in column B on each tab into a new workbook with the same tabs created. The data in column B to be split all will have the same first initial, however might have different numbers following. See before picture (there is data in column C, it's just been removed):

The end should look like this, for each first letter in column B (data removed from column C):

Also, as you can see there was not any "A"s in the PY1 Role Conflict tab.

Also if possible with the split book, can I change the file name it saves as?
A = UWMSN
B = UWMIL
C = UWEAU
D = UWGBY
E = UWLAC
F = UWOSH
G = UWPKS
H = UWPLT
J = UWRVF
K = UWSTP
L = UWSTO
M = UWSUP
N = UWWTW
W = UWSYS
Y = UWSYS

Thanks!

 

[Trebor76]

Hi cmschmitz24,

Try this on a copy of your master template just in case something goes wrong (worked fine for me on some test data):

Option Explicit
Sub Macro1()

    'https://www.mrexcel.com/board/threads/split-book-macro-with-multiple-tabs.1155395

    Dim ws As Worksheet
    Dim wb As Workbook
    Dim varMyArray As Variant
    Dim strArrayComponents() As String
    Dim strSavePath As String
    Dim lngRecCount As Long
    
    Application.ScreenUpdating = False
    
    strSavePath = "C:\Test\" 'Directory where the workbooks are to be saved. Change to suit.
    strSavePath = IIf(Right(strSavePath, 1) <> "\", strSavePath & "\", strSavePath)

    For Each varMyArray In Split("A|UWMSN,B|UWMIL,C|UWEAU,D|UWGBY,E|UWLAC,F|UWOSH,G|UWPKS," & _
                                 "H|UWPLT,J|UWRVF,K|UWSTP,L|UWSTO,M|UWSUP,N|UWWTW,W|UWSYS,Y|UWSYS", ",")
        strArrayComponents = Split(varMyArray, "|")
        ActiveWorkbook.Sheets.Copy 'Copy all the sheets to a new workbook.
        Set wb = ActiveWorkbook
        'Save the new workbook in xlsx format (this format won't store macros). Change to suit.
        Application.DisplayAlerts = False
            wb.SaveAs strSavePath & strArrayComponents(1) & ".xlsx"
        Application.DisplayAlerts = True
        For Each ws In wb.Sheets
            ws.AutoFilterMode = False 'Remove all filters
            With ws.Range("B1", ws.Range("B" & Rows.Count).End(xlUp))
                lngRecCount = Evaluate("COUNTIF('" & ws.Name & "'!" & ws.Range("B1", ws.Range("B" & Rows.Count).End(xlUp)).Address & ",""=" & CStr(strArrayComponents(0)) & "*"")")
                If lngRecCount = 0 Then
                    .Offset(1).EntireRow.Delete
                Else
                    .AutoFilter Field:=1, Criteria1:="<>" & CStr(strArrayComponents(0)) & "*"
                    .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End If
            End With
            ws.AutoFilterMode = False 'Remove all filters
        Next ws
        wb.Close SaveChanges:=True 'Close workbook after creating it. Comment out to leave it open.
    Next varMyArray
    
    Application.ScreenUpdating = True
    
    MsgBox "Workbooks have now been created.", vbInformation
    
End Sub

Regards,

Robert