Авто фильтр для выбора только видимых строк

Question

У меня есть этот код. Он перебирает список для критериев фильтрации, а затем, если никакие данные для его выбора не отображают все данные снова и не переходят к следующим критериям. Если он показывает данные, они заканчиваются (slDown) и выбирают все отображаемые данные, копируют их и вставляют в другой рабочий лист.

Сценарий очистки очищает любые пустые строки и столбцы, а затем возвращается к исходной таблице данных и удаляет данные, выбранные для копии.

Проблема в том, что есть только одна строка. Он перемещается в строку с данными, но когда я заканчиваю (xlDown), он полностью отходит до нижней части, а затем паста заставляет замораживать макрос.

Я вложил другую инструкцию if для захвата, если есть только одна строка данных, но я не могу заставить ее функционировать правильно. Любые предложения по вложенному оператору if?

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 

Answer 1

Я понял это. Вот что я сделал. Спасибо всем!

Я использовал это Если 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 

Answer 2

Я думаю, что ваш код может быть намного чище, чем это. Я предпочитаю использовать вспомогательную функцию для создания этого фильтра. Что-то вроде этого:

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 

Answer 3

Вот исходный код переписан с помощью Range.CurrentRegion property определить диапазон ячеек для фильтрации.

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 function никогда не включает в себя отфильтрованные или скрытые строки, поэтому запрос количества будет определять, есть ли что-либо для копирования. Изменение размера и смещение перемещается в отфильтрованный диапазон.

Вам необходимо будет повторно включить подпрограмму «Очистка».