Excel 使用多个列过滤器将数据拆分为多个工作表

使用单个筛选器可以回答此问题。但是如何基于多个过滤器（列）将工作表拆分为多个工作表呢。我在下面有这个工作表

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

我想根据3列（分支、部门、部门）将其拆分为多个工作表。结果应该如下所示：

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

如何编写VBA Excel宏来执行此操作？ 此外，每张工作表应以“部门”字母命名。（例如，Branch1第2节）

目前，我有一个VBA代码，可以对1列进行过滤

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

---

我刚把它拼凑起来。它似乎和你描述的一样。注意，我从C1:E7复制了数据并将其粘贴到AA1中，然后单击了数据>删除重复项。您可以录制一个宏来执行此操作，并将其添加到代码的顶部

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

之前：

之后：

我在下面添加了一些修改后的代码，以解决您的最后一个问题。使用下面的代码，并保留名为“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

---

谢谢你提供的有用信息！另一个问题：在新创建的工作表中，如果我只想要名称和年龄列，那将如何编写？我还注意到宏删除了原始数据工作表。是否有一种方法可以保留数据工作表，同时允许宏理解何时停止？我只是添加了一些稍微修改的代码来处理您的问题。如果我的答案对你有帮助，请投票表决。谢谢！这对我帮助很大。我认为这个解决方案将对社区非常有帮助，因为在多个列上进行过滤时没有太多的解决方案。我对你的答案投了更高的票，但没有显示出来，因为我没有至少15个声誉。最后一个问题：有没有办法将每个新创建的选项卡保存为一个.txt文件，文件名为工作表选项卡名？这只是一个简单的谷歌搜索。当然很乐意帮忙。