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

Question

使用单个过滤器可以回答这个问题。但是如何根据超过 1 个过滤器（列）将工作表拆分为多个工作表。我在下面有这个工作表。

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 列（Branch、Section、Dept）将其拆分为多个工作表。结果应如下所示：

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 宏来执行此操作？ 此外，每个工作表都应命名为“BRANCH”#&“SECTION”#&“DEPT”字母。 （例如 BRANCH1SECTION2DEPTA）

目前，我有这个 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

Answer 1

我只是一起破解了这个。它似乎做了你描述的事情。注意，我从 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