Split data into multiple worksheets using MULTIPLE column filters

Question

There are answers to this question using a single filter. BUT How do you split a worksheet into multiple worksheets based off of more than 1 filter (column). I have this worksheet below.

Name     Age     Branch     Section     Dept
Bob      20      1          2           A
Bill     20      1          2           A
Jill     20      1          2           B
Jane     20      1          3           A
Paul     20      2          3           B
Tom      20      2          3           B

I want to split this into multiple worksheets based off of 3 columns (Branch, Section, Dept). The results should look like this:

Name     Age     Branch     Section     Dept
Bob      20      1          2           A
Bill     20      1          2           A

Name     Age     Branch     Section     Dept
Jill     20      1          2           B

Name     Age     Branch     Section     Dept
Jane     20      1          3           A

Name     Age     Branch     Section     Dept
Paul     20      2          3           B
Tom      20      2          3           B

How would I write a VBA Excel macro to do this? Also each worksheet should be named "BRANCH" # & "SECTION" # & "DEPT" letter. (e.g. BRANCH1SECTION2DEPTA)

Currently, I have this VBA code that can do this filtering for 1 column.

Sub SplitandFilterSheet()

'Step 1 - Name your ranges and Copy sheet
'Step 2 - Filter by Department and delete rows not applicable
'Step 3 - Loop until the end of the list

Dim Splitcode As Range
Sheets("Master").Select
Set Splitcode = Range("Splitcode")

For Each cell In Splitcode
Sheets("Master").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = cell.Value

With ActiveWorkbook.Sheets(cell.Value).Range("MasterData")
.AutoFilter Field:=6, Criteria1:="NOT EQUAL TO" & cell.Value, Operator:=xlFilterValues
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With

ActiveSheet.AutoFilter.ShowAllData
Next cell
End Sub

Answer 1

I just hacked this together. It seems to do what you described. Notice, I copied the data from C1:E7 and pasted it into AA1, then clicked Data > Remove Duplicates. You can record a Macro to do this and add it to the code, towards the top.

Sub Copy_To_Worksheets()

    Dim My_Range As Range
    Dim FieldNum As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim ws2 As Worksheet
    Dim Lrow As Long
    Dim cell As Range
    Dim CCount As Long
    Dim WSNew As Worksheet
    Dim ErrNum As Long


    Set My_Range = Range("A1:E" & LastRow(ActiveSheet))
    My_Range.Parent.Select


    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws = Worksheets("Data")

    With ws

        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        'For Each cell In .Range("A2:A" & Lrow)
            For Each c In Range("AA2:AA5")
                 'Filter the range

                 My_Range.AutoFilter Field:=3, Criteria1:="=" & c.Value
                 My_Range.AutoFilter Field:=4, Criteria1:="=" & c.Offset(0, 1).Value
                 My_Range.AutoFilter Field:=5, Criteria1:="=" & c.Offset(0, 2).Value

                    Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
                    On Error Resume Next
                    WSNew.Name = "Branch" & c.Value & "Section" & c.Offset(0, 1).Value & "Dept" & c.Offset(0, 2).Value
                    On Error GoTo 0

                    'Copy the visible data to the new worksheet
                    My_Range.SpecialCells(xlCellTypeVisible).Copy
                    With WSNew.Range("A1")

                        .PasteSpecial Paste:=8
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                        Application.CutCopyMode = False
                        .Select
                    End With

            Next c
        'Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

    'Turn off AutoFilter
    'My_Range.Parent.AutoFilterMode = False

    If ErrNum > 0 Then
        MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
             & vbNewLine & "There are characters in the name that are not allowed" _
             & vbNewLine & "in a sheet name or the worksheet already exist."
    End If

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    'My_Range.Parent.Select
    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

End Sub


Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlValues, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Before:

After:

I am adding some modified code below, to address your last question. Use the code below, and keep the Function named 'LastRow'.

Sub TryThis()

    Dim My_Range As Range
    Dim FieldNum As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim ws2 As Worksheet
    Dim Lrow As Long
    Dim cell As Range
    Dim CCount As Long
    Dim WSNew As Worksheet
    Dim ErrNum As Long


    Set My_Range = Range("A1:E" & LastRow(ActiveSheet))
    My_Range.Parent.Select


    'Turn off AutoFilter
    My_Range.Parent.AutoFilterMode = False

    'Change ScreenUpdating, Calculation, EnableEvents, ....
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

    'Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws = Worksheets("Data")

    With ws

        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row

            For Each c In Range("AA2:AA5")
                 'Filter the range

                 My_Range.AutoFilter Field:=3, Criteria1:="=" & c.Value
                 My_Range.AutoFilter Field:=4, Criteria1:="=" & c.Offset(0, 1).Value
                 My_Range.AutoFilter Field:=5, Criteria1:="=" & c.Offset(0, 2).Value

                    Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
                    On Error Resume Next
                    WSNew.Name = "Branch" & c.Value & "Section" & c.Offset(0, 1).Value & "Dept" & c.Offset(0, 2).Value
                    On Error GoTo 0

                    'Copy the visible data to the new worksheet
                    My_Range.SpecialCells(xlCellTypeVisible).Copy
                    With WSNew.Range("A1")

                        .PasteSpecial Paste:=8
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                        Application.CutCopyMode = False
                        .Select
                    End With

                Columns("C:E").Select
                Selection.ClearContents

            Next c

    End With

    'Turn off AutoFilter
    'My_Range.Parent.AutoFilterMode = False

    If ErrNum > 0 Then
        MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
             & vbNewLine & "There are characters in the name that are not allowed" _
             & vbNewLine & "in a sheet name or the worksheet already exist."
    End If

    'Restore ScreenUpdating, Calculation, EnableEvents, ....
    'My_Range.Parent.Select
    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

End Sub