自動過濾器不返回任何行，但可見范圍只是過濾后的可見范圍不是什么

Question

所以這是代碼的相關部分：

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

Feuil1 中的第一行是帶有過濾器標題的行。

問題是，當 Criteria1 沒有給出任何行作為結果時，因此唯一可見的行是帶有過濾器的行，在這種情況下，可見范圍什么都不是，但FilteredRng is Nothing給出 False 作為結果，因為由於某種原因 FilteredRng 實際上是過濾器的第一行。

我不明白這是怎么發生的，因為第一行不是開始范圍的一部分。

此外，它可以防止我使用if FilteredRng is Nothing then來捕獲錯誤

現在的解決方法是if FilteredRng.rows.count = 1 and FilteredRng.row=1 then但我仍然希望能夠通過與 Nothing 作為過濾器行/ header 行進行比較來捕獲錯誤。案例......我有預建的函數和子程序，用於一般案例使用，我與Nothing進行比較。

如果有人知道這里發生了什么或如何捕捉“未找到單元格”錯誤，我將不勝感激。

更新：

根據 Rory 的評論更新代碼后，代碼如下所示：

On Error Resume Next
Feuil1.ShowAllData
On Error GoTo 0

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 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

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("*@*")

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)
        
        Set FilteredRng = Nothing
        Feuil1.Range("A1" & ":" & HelpAddress).AutoFilter Field:=4
        Feuil1.Range("A1" & ":" & HelpAddress).AutoFilter Field:=4, Criteria1:=HelpArr2(i), Operator:=xlFilterValues
        On Error Resume Next
        Set FilteredRng = Feuil1.Range("A2" & ":" & HelpAddress).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not FilteredRng Is Nothing Then
'        If FilteredRng.Rows.count = 1 And FilteredRng.Row = 1 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

Answer 1

參考自動過濾可見單元格

• 這是如何解決此問題的示例。

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

Answer 2

對於表格，header 行和數據主體（不包括標題）范圍可用作表格的屬性。

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

Answer 3

這個答案應該歸功於Rory，因為他的評論提供了解決方案

所以這個問題的答案是將范圍設置為空，應用所需的過濾器，然后使用 SpecialCells 屬性設置范圍。

        Set FilteredRng = Nothing
        Feuil1.Range("A1:" & HelpAddress).AutoFilter Field:=4
        Feuil1.Range("A1:" & HelpAddress).AutoFilter Field:=4, Criteria1:=HelpArr2(i), Operator:=xlFilterValues
        On Error Resume Next
        Set FilteredRng = Feuil1.Range("A2:" & HelpAddress).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not FilteredRng Is Nothing Then
            'Code here
        End If