将多个条件过滤到单独的工作表中

Question

我希望将同一个表中的多个条件过滤到单独的工作表中，并分配到特定范围内。

例如我的桌子范围是 A1:F5。过滤条件在 A 列。如果 A=dog，则包含 cat 的行将从 A3 开始粘贴到 sheet2，如果 A=cat，则包含 cat 的行将从 G10 开始粘贴到 sheet3。

我尝试将每个模块放在单独的模块中，并使用 call 函数调用具有各自过滤条件的各个模块，但它只运行第一个过滤模块并停止。征求你的意见。谢谢你:)

Sub filter02()


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'Set the destination worksheet
Set DestSh = Sheets("Sheet3")

If ActiveWorkbook.ProtectStructure = True Or _
   My_Range.Parent.ProtectContents = True Then
    MsgBox "Sorry, not working when the workbook or worksheet is protected", _
           vbOKOnly, "Copy to new worksheet"
    Exit Sub
End If

'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

'Firstly, remove the AutoFilter
My_Range.Parent.AutoFilterMode = False

'Filter and set the filter field and the filter criteria :
'This example filter on the first column in the range (change the field if needed)
'In this case the range starts in A so Field 1 is column A, 2 = column B, ......
My_Range.AutoFilter Field:=1, Criteria1:="=TPFT"

'If you want to filter on a cell value you can use this, use "<>" for the opposite
'This example uses the activecell value
'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value

'This will use the cell value from A2 as criteria
'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value

''If you want to filter on a Inputbox value use this
'FilterCriteria = InputBox("What text do you want to filter on?", _
 '                          "Enter the filter item.")
'My_Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria


'Check if there are not more then 8192 areas(limit of areas that Excel can copy)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
    MsgBox "There are more than 8192 areas:" _
         & vbNewLine & "It is not possible to copy the visible data." _
         & vbNewLine & "Tip: Sort your data before you use this macro.", _
           vbOKOnly, "Copy to worksheet"
Else
    'Copy the visible data and use PasteSpecial to paste to the Destsh
    With My_Range.Parent.AutoFilter.Range
        On Error Resume Next
        ' Set rng to the visible cells in My_Range without the header row
        Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
                  .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rng Is Nothing Then
            'Copy and paste the cells into DestSh below the existing data
            rng.Copy
            With DestSh.Range("A" & LastRow(DestSh) + 1)
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                ' Remove this line if you use Excel 97
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
            'Delete the rows in the My_Range.Parent worksheet
            'rng.EntireRow.Delete
        End If

'Close AutoFilter
My_Range.Parent.AutoFilterMode = False

'Restore ScreenUpdating, Calculation, EnableEvents, ....
ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
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

Answer 1

这样的东西应该适合你：

Sub SplitDataToWorksheetsByCriteria()
'Purpose is to split data from a master sheet into separate sheets based on a criteria column
'Written by tigeravatar on www.stackoverflow.com on 2018-Feb-27

    ''''''''''''''''''''''''''''''''''''''''''
    '                                        '
    '  Adjust these parameters as necessary  '
    '                                        '
    Const sDataSh As String = "Master"
    Const sCritCol As String = "A"
    Const lHeaderRow As Long = 1
    Const sCopyCols As String = "A:F"
    Const bOverwrite As Boolean = True
    '                                        '
    ''''''''''''''''''''''''''''''''''''''''''

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rData As Range
    Dim rDest As Range
    Dim aData As Variant
    Dim dictUnq As Object
    Dim sInvalidChars As String
    Dim sName As String
    Dim lCritCol As Long
    Dim lUnqCount As Long
    Dim i As Long, j As Long

    Set wb = ActiveWorkbook
    Set wsData = wb.Sheets(sDataSh)
    Set rData = wsData.Range(sCritCol & lHeaderRow).CurrentRegion
    If rData.Rows.Count = 1 Then Exit Sub   'No data

    'If sorting master data, uncomment these lines and adjust sort parameters as necessary
    'With rData
    '    .Sort Intersect(.EntireRow, wsData.Columns(sCritCol).EntireColumn), xlAscending, Header:=xlYes
    'End With

    aData = rData.Value
    lCritCol = wsData.Columns(sCritCol).Column - rData.Column + 1
    sInvalidChars = ":\/?*[]"

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set dictUnq = CreateObject("Scripting.Dictionary")
    For i = LBound(aData, 1) + 1 To UBound(aData, 1)    '+1 to avoid header row
        'Check for new unique value
        On Error Resume Next
        dictUnq.Add aData(i, lCritCol), aData(i, lCritCol)
        On Error GoTo 0
        If dictUnq.Count > lUnqCount Then
            'New unique value found
            lUnqCount = dictUnq.Count

            'Convert value to valid worksheet name
            sName = aData(i, lCritCol)
            For j = 1 To Len(sInvalidChars)
                sName = Replace(sName, Mid(sInvalidChars, j, 1), " ")
            Next j
            sName = Trim(Left(WorksheetFunction.Trim(sName), 31))

            'Check if sheet name exists
            On Error Resume Next
            Set wsDest = wb.Sheets(sName)
            On Error GoTo 0
            If wsDest Is Nothing Then
                'Sheet doesn't exist, create
                wb.Sheets.Add After:=wb.Sheets(wb.Sheets.Count)
                Set wsDest = ActiveSheet
                wsDest.Name = sName
                Intersect(rData.Resize(1).EntireRow, wsData.Range(sCopyCols).EntireColumn).Copy wsDest.Range("A1") 'Copy over headers
            End If

            'Check if overwriting existing data or not
            If bOverwrite = True Then
                wsDest.Range("A1").CurrentRegion.Clear
                Intersect(rData.Resize(1).EntireRow, wsData.Range(sCopyCols).EntireColumn).Copy wsDest.Range("A1") 'Copy over headers
                Set rDest = wsDest.Range("A2")
            Else
                Set rDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
            End If

            'Copy over relevant data
            rData.AutoFilter lCritCol, aData(i, lCritCol)
            Intersect(rData.EntireRow, wsData.Range(sCopyCols).EntireColumn).Offset(1).Copy rDest
            rData.AutoFilter

            Set wsDest = Nothing
        End If
    Next i

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    'Cleanup
    Set wb = Nothing
    Set ws = Nothing
    Set wsData = Nothing
    Set wsDest = Nothing
    Set rData = Nothing
    Set rDest = Nothing
    Set dictUnq = Nothing
    Erase aData

End Sub