Auto filter to select just the visible rows - excel

Question

I have this code. It loops through a list for the filtering criteria, then if no data to select it shows all data again and loops to the next criteria. If it shows data it end(slDown) and selects all the data showing, copies it and pastes it into another worksheet.
The cleanup script cleans any blank rows and columns and then returns to the original data sheet and deletes the data selected for the copy paste.
The problem is when there is just one row. It moves to the row with data, but when I End(xlDown), it shoots all the way to the bottom and the paste then causes the macro to freeze up.
I nested another if statement to capture if there is only one line of data visible, but I cannot get it to function correctly. Any Suggestions on the nested if statement?
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

I figured it out.... Here is what I did. Thanks all!
I used this If ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas.Count <= 2
instead of this (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

I think your code could be much cleaner than this. I prefer to use an auxiliar funcion to make this filter. Something like this:
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

Here is your original code rewritten using the Range.CurrentRegion property to define the range of cells to be filtered.
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
Here is the same thing that collects all of the criteria terms from the Reference worksheet into a variant array and uses that to filter for all terms at once.
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
The latter is likely a few milli-seconds faster than the first.
The worksheet's SUBTOTAL function never includes filtered or hidden rows so asking for a count will determine if there is anything to copy. Resizing and offsetting moves to the filtered range.
You will need to reincorporate the Cleanup subroutine.