将多个条件过滤到单独的工作表中 [英] Filtering multiple criteria into separate worksheets

问题描述

我希望将同一表格中的多个条件过滤到特定范围内的单独工作表中.

I'm looking to filter multiple criteria in the same table into separate worksheets into specific ranges.

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

E.g. my table is range is A1:F5. Filter criteria is in column A. If A=dog, the row containing cat will paste into sheet2 starting from A3, if A=cat the row containing cat will paste go into sheet3 starting from G10.

我尝试将每个模块放置在单独的模块中，并使用call函数使用各自的过滤条件来调用各个模块，但是它仅运行第一个过滤器模块并停止.征求您的意见.谢谢:)

I have tried to place each in separate modules and use the call function to call individual modules with respective filter criteria, but it only runs the first filter module and stops. Seek your advice on this. Thank you :)

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

推荐答案

类似的方法应该对您有用:

Something like this should work for you:

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

这篇关于将多个条件过滤到单独的工作表中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！