Autofilter Returns no rows but so the visible range is nothing but the Filtered Visible Range is not-CodePudding

So this is the relevant part of the code:

i = Feuil1.Cells.Rows.count

i = Feuil1.Cells(i, 1).End(xlUp).Row
j = Feuil1.Cells(1, 1).End(xlToRight).Column
HelpAddress = Feuil1.Cells(i, j).Address

Set Table = Feuil1.ListObjects("FiltersTable")

HelpArr = Application.WorksheetFunction.Transpose(Table.ListColumns("Rubriques").DataBodyRange)
HelpArr2 = Application.WorksheetFunction.Transpose(Table.ListColumns("Departements").DataBodyRange)
HelpArr = UniqueNoEmpty(HelpArr)
HelpArr2 = UniqueNoEmpty(HelpArr2)

For i = LBound(HelpArr2) To UBound(HelpArr2)
    HelpArr2(i) = CStr(HelpArr2(i)) & "*"
Next i

FilterArray2 = Array("*@*")

Set Wbk = Workbooks.Add
Set Ws = Wbk.Worksheets(1)
Feuil1.Activate
Feuil1.Range("A1" & ":" & Feuil1.Cells(1, j).Address).Copy
Ws.Cells(1, 1).PasteSpecial xlPasteValues

For Each Rubrique In HelpArr
    
    FilterArray = Array(Rubrique & "*")
    
    With Feuil1
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
'        .Range("A1" & ":" & HelpAddress).AutoFilter Field:=11
        .Range("A1" & ":" & HelpAddress).AutoFilter Field:=11, Criteria1:=FilterArray, Operator:=xlFilterValues
        .Range("A1" & ":" & HelpAddress).AutoFilter Field:=9, Criteria1:=FilterArray2, Operator:=xlFilterValues
'        .Range("A1" & ":" & HelpAddress).AutoFilter Field:=4, Criteria1:=FilterArray3, Operator:=xlFilterValues, Operator:=xlOr
    End With
    
    For i = LBound(HelpArr2) To UBound(HelpArr2)
        
        Feuil1.Range("A1" & ":" & HelpAddress).AutoFilter Field:=4
        Feuil1.Range("A1" & ":" & HelpAddress).AutoFilter Field:=4, Criteria1:=HelpArr2(i), Operator:=xlFilterValues
        Set FilteredRng = Feuil1.Range("A2" & ":" & HelpAddress).SpecialCells(xlCellTypeVisible)
        
        If Not FilteredRng Is Nothing Then
            FilteredRng.Copy
            Set HelpRng = Ws.Cells(Ws.Cells.Rows.count, 1).End(xlUp)
            Do While HelpRng.Value <> ""
                Set HelpRng = HelpRng.Offset(1, 0)
            Loop
            Ws.Range(HelpRng.Address).PasteSpecial xlPasteValues
        End If
        
    Next i
    
Next Rubrique

The first line in Feuil1 is the row with the headers with filters.

The thing is that when the Criteria1 gives no rows as result, and so the only visible row is the row with the filters, in that case the visible range is nothing BUT FilteredRng is Nothing gives False as result because for some reason FilteredRng is actually the first row with the filters.

I can't understand how this happens because the first row was not part of the range to begin with.

Furthermore it prevents me from catching the error using if FilteredRng is Nothing then

Now the workaround for this is if FilteredRng.rows.count = 1 and FilteredRng.row=1 then but still I'd like to be able to catch the error by comparing with Nothing as the filter row / header row might change rows in different cases... and I have pre-built functions and subs that are for general case use where I compare to Nothing.

If anyone knows what's going on here or how to catch the 'No cells found' error I would really appreciate it.

CodePudding user response：

Reference AutoFilter Visible Cells

Here's an example of how to tackle this.

Option Explicit

Sub AutoFilterExample()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    If ws.AutoFilterMode Then ws.AutoFilterMode = False ' remove previous
    
    Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion ' Table Range
    Dim dtrg As Range ' Data Range (refernce before the 'AutoFilter')
    Set dtrg = trg.Resize(trg.Rows.Count - 1).Offset(1)
    
    trg.AutoFilter 1, "Yes"
    
    Dim vrg As Range ' Visible Range
    On Error Resume Next
    Set vrg = dtrg.SpecialCells(xlCellTypeVisible) ' use the data range ('dtrg')
    On Error GoTo 0
    
    ws.AutoFilterMode = False
    
    If Not vrg Is Nothing Then
        Debug.Print vrg.Address(0, 0)
    Else
        Debug.Print "Nope"
    End If
    
End Sub

CodePudding user response：

With a table the header row and databody (excluding header) ranges are available as properties of the table.

Option Explicit

Sub demo()

    Dim wsf As WorksheetFunction
    
    Dim wb As Workbook, ws As Worksheet, tbl As ListObject
    Dim wbOut As Workbook, wsOut As Worksheet, rowOut As Long
    Dim colRub As ListColumn, colDept As ListColumn
    Dim arRub, arDept, i As Long
    
    Set ws = Sheet1 ' or Feuil1
    Set wsf = Application.WorksheetFunction
    
    ' get unique rubriques and departements
    Set tbl = ws.ListObjects("FiltersTable")
    With tbl
        Set colRub = .ListColumns("Rubriques")
        arRub = UniqueNoEmpty(wsf.Transpose(colRub.DataBodyRange))
    
        Set colDept = .ListColumns("Departements")
        arDept = UniqueNoEmpty(wsf.Transpose(colDept.DataBodyRange))
    End With
    
    ' create workbook for reults
    Set wbOut = Workbooks.Add
    Set wsOut = wbOut.Worksheets(1)
    tbl.HeaderRowRange.Copy wsOut.Range("A1")
    rowOut = 1
      
    Dim rubrique, dept, rngFiltered As Range
    'Application.ScreenUpdating = False
    With tbl
        For Each rubrique In arRub
       
             ' apply rubrique filter
            .Range.AutoFilter Field:=colRub.Index, Criteria1:=rubrique & "*"
            .Range.AutoFilter Field:=9, Criteria1:="*@*"
        
            For Each dept In arDept
                
                 ' apply department filter
                .Range.AutoFilter Field:=colDept.Index, Criteria1:=dept & "*"
                    
                ' copy filtered data if any
                Set rngFiltered = Nothing
                On Error Resume Next
                Set rngFiltered = .DataBodyRange.SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If rngFiltered Is Nothing Then
                    'Debug.Print "No data for ", rubrique, dept
                Else
                    rngFiltered.Copy
                    wsOut.Range("A" & rowOut   1).PasteSpecial xlPasteValues
                    rowOut = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp).Row
                End If
            
            Next
        Next
        .Range.AutoFilter
    End With
    
    'Application.ScreenUpdating = True
    MsgBox rowOut & " rows copied to " & wbOut.Name

End Sub

Function UniqueNoEmpty(ar)
    Dim d, e: Set d = CreateObject("Scripting.Dictionary")
    For Each e In ar
        If Len(e) > 0 Then d(CStr(e)) = 1
    Next
    UniqueNoEmpty = d.keys
End Function