AutoFilter/RemoveDuplicates 三明治
强调
- 您将
AutoFilter 应用于包括标题在内的完整范围（表格）。
- 您从数据范围中删除行，即没有标题的范围（表格），或者您将删除标题。
- 从范围中删除行时，引用（其地址）发生变化（“收缩”），代码中的
Debug.Print 行说明了这一点。
-
RemoveDuplicates 不会更改范围参考。因此，范围是在最终过滤之前重新设置的。
- 删除所有数据行时，使用数据范围(
drg) 例如获取其地址 (drg.Address) 将失败并出现 Object required 错误 (424)，因为它“超出范围”，即没有行。请注意，它不会是Nothing。
- 请注意两次出现的
ws.AutoFilterMode = False 的重要性。如果您不使用它们，系统会要求您删除全部的行，如果您拒绝，则会发生错误。
Sub FilterData()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Result")
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Allow user to view the worksheet if a warning message appears.
If Not wb Is ActiveWorkbook Then wb.Activate
' An error would occur if 'ThisWorkbook' were not active!
If Not ws Is ActiveSheet Then ws.Activate
Dim hrrg As Range: Set hrrg = ws.Range("A2:I2") ' Header Row Range
Dim trg As Range ' Table Range (has headers)
Dim drg As Range ' Data Range (no headers)
Dim frg As Range ' Filtered Data Range (no headers)
' 1.) Filter
Set trg = SetColumns(hrrg)
If trg Is Nothing Then Exit Sub ' empty range
If trg.Rows.Count = 1 Then Exit Sub ' only headers
Set drg = trg.Resize(trg.Rows.Count - 1).Offset(1)
Debug.Print "0.)", "trg: " & trg.Address(0, 0), "drg: " & drg.Address(0, 0)
trg.AutoFilter Field:=1, Criteria1:=""
On Error Resume Next
Set frg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False
If Not frg Is Nothing Then
Debug.Print "1.)", "frg: " & frg.Address(0, 0)
frg.Delete xlShiftUp
Set frg = Nothing
End If
If trg.Rows.Count > 1 Then
Debug.Print "1.)", "trg: " & trg.Address(0, 0), "drg: " & drg.Address(0, 0)
Else
Debug.Print "1.)", "trg: " & trg.Address(0, 0), "drg: " & "No object"
End If
' 2.) Remove Duplicates
If trg.Rows.Count >= 3 Then
trg.RemoveDuplicates Columns:=Array(1), Header:=xlYes
' There are at least two rows.
Set trg = SetColumns(hrrg)
Set drg = trg.Resize(trg.Rows.Count - 1).Offset(1)
'Else ' too few rows (headers + 2 rows needed); no duplicates; do nothing
End If
If trg.Rows.Count > 1 Then
Debug.Print "2.)", "trg: " & trg.Address(0, 0), "drg: " & drg.Address(0, 0)
Else
Debug.Print "2.)", "trg: " & trg.Address(0, 0), "drg: " & "No object"
End If
' 3.) Filter
If trg.Rows.Count = 1 Then Exit Sub ' only headers
trg.AutoFilter Field:=5, Operator:=xlFilterValues, Criteria1:=Array( _
"BE", "BG", "DK", "DE", "EE", "FI", "FR", "GR", "IE", _
"IT", "HR", "LV", "LT", "LU", "MT", "NL", "AT", "PL", _
"PT", "RO", "SE", "SK", "SI", "ES", "CZ", "HU", "CY")
On Error Resume Next
Set frg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False
If Not frg Is Nothing Then
Debug.Print "3.)", "frg: " & frg.Address(0, 0)
frg.Delete xlShiftUp
Set frg = Nothing
End If
If trg.Rows.Count > 1 Then
Debug.Print "3.)", "trg: " & trg.Address(0, 0), "drg: " & drg.Address(0, 0)
Else
Debug.Print "3.)", "trg: " & trg.Address(0, 0), "drg: " & "No object"
End If
End Sub
Function SetColumns( _
ByVal FirstRowRange As Range) _
As Range
With FirstRowRange.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set SetColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function
即时窗口中的结果
0.) trg: A2:I22 drg: A3:I22
1.) frg: A6:I7,A9:I9,A11:I11,A22:I22
1.) trg: A2:I17 drg: A3:I17
2.) trg: A2:I13 drg: A3:I13
3.) frg: A4:I4,A6:I6,A10:I10,A12:I13
3.) trg: A2:I8 drg: A3:I8