我希望将同一个表中的多个条件过滤到特定范围内的单独工作表中。
E.g。我的表是范围是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
答案 0 :(得分：-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