自动筛选只select可见的行
我有这个代码。 它通过筛选条件的列表进行循环，如果没有数据select它将再次显示所有数据并循环到下一个条件。 如果显示的数据结束（slDown）并select所有显示的数据，则将其复制并粘贴到另一个工作表中。
清除脚本将清除所有空白行和列，然后返回到原始数据表并删除为复制粘贴所选的数据。
问题是只有一行。 它移动到有数据的行，但是当我结束（xlDown）时，它一路拍摄到底部，然后粘贴导致macros观冻结。
我嵌套另一个if语句来捕获是否只有一行数据可见，但我不能让它正常工作。 有关嵌套if语句的任何build议？
Dim criteria As String Dim F As Range Set Rng = Sheets("Reference").Range("W2:W36") For Each F In Rng criteria = F ActiveSheet.Range("$AV$1").AutoFilter Field:=48, Criteria1:="=*BULK SUBSERVIENT*", Operator:=xlAnd ActiveSheet.Range("$K$1").AutoFilter Field:=11, Criteria1:=criteria Range("A2:CM" & ActiveSheet.UsedRange.Rows.Count + 1) _ .Cells.SpecialCells(xlCellTypeVisible).Rows(1).Select If ActiveCell.Value = vbNullString Then ActiveSheet.ShowAllData Else If (ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell)) = 2 Then 'Range(Selection).Select Selection.Copy Sheets("Bulk Subservient").Select ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select ActiveSheet.Paste Call cleanup Else Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets("Bulk Subservient").Select ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select ActiveSheet.Paste Call cleanup End If End If Next F 我知道了….这是我做的。 谢谢大家！
我用这个如果ActiveSheet.UsedRange.SpecialCells（xlCellTypeVisible）.Areas.Count <= 2代替这个（ActiveSheet.UsedRange.SpecialCells（xlCellTypeLastCell））= 2
Dim criteria As String Dim F As Range Set Rng = Sheets("Reference").Range("W2:W36") For Each F In Rng criteria = F ActiveSheet.Range("$AV$1").AutoFilter Field:=48, Criteria1:="=*BULK SUBSERVIENT*", Operator:=xlAnd ActiveSheet.Range("$K$1").AutoFilter Field:=11, Criteria1:=criteria Range("A2:CM" & ActiveSheet.UsedRange.Rows.Count + 1) _ .Cells.SpecialCells(xlCellTypeVisible).Rows(1).Select If ActiveCell.Value = vbNullString Then ActiveSheet.ShowAllData Else If ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas.Count <= 2 Then 'Range(Selection).Select Selection.Copy Sheets("Bulk Subservient").Select ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select ActiveSheet.Paste Call cleanup Else Range(Selection, Selection.End(xlDown)).Select Selection.Copy Sheets("Bulk Subservient").Select ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select ActiveSheet.Paste Call cleanup End If End If Next F
我认为你的代码可能比这更干净。 我更喜欢使用辅助function来制作这个filter。 像这样的东西：
Function MyFilter(criteria as string) as Range Set tableRange = ActiveSheet.UsedRange ' Filter With tableRange Call .AutoFilter(48, "*BULK SUBSERVIENT*") Call .AutoFilter(11, criteria) End With On Error Resume Next 'This... Set selectedRange = tableRange.SpecialCells(xlCellTypeVisible) '...Or (how to remover title). Set selectedRange = Intersect(tableRange.SpecialCells(xlCellTypeVisible), .[2:1000000]) On Error GoTo 0 With tableRange Call .AutoFilter(11) Call .AutoFilter(48) End With 'Empty Criteria If WorksheetFunction.CountA(selectedRange) < 2 Then Exit Sub End If Set MyFilter = selectedRange End Sub
这里是你使用Range.CurrentRegion属性重写的原始代码来定义要过滤的单元格的范围。
Dim criteria As String Dim F As Range, rng As Range With Worksheets("Reference") Set rng = .Range(.Cells(2, 23), .Cells(Rows.Count, 23).End(xlUp)) End With With ActiveSheet '<~~ set this to worksheets("Sheet1") as appropriate If .AutoFilterMode Then .AutoFilterMode = False With .Cells(1, 1).CurrentRegion For Each F In rng criteria = F .AutoFilter Field:=48, Criteria1:="*BULK SUBSERVIENT*" .AutoFilter Field:=11, Criteria1:=criteria With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) If CBool(Application.Subtotal(103, .Cells)) Then .Copy Destination:=Sheets("Bulk Subservient").Cells(Rows.Count, 1).End(xlUp).Offset(1) End If End With Next F End With If .AutoFilterMode Then .AutoFilterMode = False End With
以下是将“参考”工作表中的所有条件术语收集到变体数组中并使用该数据同时过滤所有术语的相同内容。
Dim rng As Range Dim vCRITERIA As Variant, v As Long With Worksheets("Reference") ReDim vCRITERIA(1 To 1) '<~~for alternate method For Each rng In .Range(.Cells(2, 23), .Cells(Rows.Count, 23).End(xlUp)) vCRITERIA(UBound(vCRITERIA)) = rng.Value2 ReDim Preserve vCRITERIA(UBound(vCRITERIA) + 1) Next rng ReDim Preserve vCRITERIA(UBound(vCRITERIA) - 1) End With With ActiveSheet '<~~ set this to worksheets("Sheet1") as appropriate If .AutoFilterMode Then .AutoFilterMode = False With .Cells(1, 1).CurrentRegion .AutoFilter Field:=48, Criteria1:="*BULK SUBSERVIENT*" .AutoFilter Field:=11, Criteria1:=(vCRITERIA), Operator:=xlFilterValues With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) If CBool(Application.Subtotal(103, .Cells)) Then .Copy Destination:=Sheets("Bulk Subservient").Cells(Rows.Count, 1).End(xlUp).Offset(1) End If End With End With If .AutoFilterMode Then .AutoFilterMode = False End With
后者可能比第一次快几毫秒。
工作表的SUBTOTAL函数从不包含过滤或隐藏的行，因此要求计数将确定是否有任何要复制的内容。 resize和偏移移动到过滤的范围。
您将需要重新组织Cleanup子例程。