所以這是代碼的相關部分：
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 進行比較來捕獲錯誤，因為過濾器行/標題行可能會在不同情況下更改行......而且我有預先構建的函式和子程式對于一般情況使用，我比較什么都沒有。
如果有人知道這里發生了什么或如何捕獲“未找到單元格”錯誤，我將不勝感激。
更新：
按照 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
uj5u.com熱心網友回復：
參考自動篩選可見單元格
- 這是一個如何解決這個問題的例子。
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
uj5u.com熱心網友回復：
對于表格，標題行和資料主體（不包括標題）范圍可用作表格的屬性。
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
uj5u.com熱心網友回復：
這個答案的功勞應該歸功于 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
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/401424.html