VBA按条件删行时无匹配项误删整表的解决方法咨询

我编写了VBA宏代码，用于在工作表"1.0"和"2.0"的B列（对应ColumntoFilter1=2）匹配指定条件时删除对应行。但运行代码时，若criteria6（值为"LPXP"）无匹配项，会误删整个工作表。需要修改代码，使其在无匹配项时不执行删除操作，直接继续后续命令。

原代码 #

' MACRO TO DELETE SYSTEMATIC USERNAMES
Dim rngTable As Range
Dim ws As Worksheet
Dim StartCell As Range

Const ColumntoFilter1 As Integer = 2
Const FilterCriteria1 As String = "ASH"
Const FilterCriteria2 As String = "HPD"
Const FilterCriteria3 As String = "INQUIRY"
Const FilterCriteria4 As String = "BULKOPS"
Const FilterCriteria5 As String = "AHIN1"
Const FilterCriteria6 As String = "LPXP"
Const FilterCriteria7 As String = "PPI_BATCH"
Const FilterCriteria8 As String = "REPROCESSOR"

' DELETES SYSTEM USERNAMES FROM 1.0 TAB
Set ws = Sheets("1.0")
' Set the starting position (Top-left most position) of your data range
Set StartCell = ws.Range("A1")

' Turn off autofilter in case it's already active
ws.AutoFilterMode = False
' Define data table
Set rngTable = StartCell.CurrentRegion
' Filter and delete data
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria1
    .Offset(1, 0).EntireRow.Delete
End With
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria2
    .Offset(1, 0).EntireRow.Delete
End With
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria6
    .Offset(1, 0).EntireRow.Delete
End With
' Turn filters off again
ws.AutoFilterMode = False

Set rngTable = Nothing
Set StartCell = Nothing
Set ws = Nothing

' DELETES SYSTEM USERNAMES FROM 2.0 TAB
Set ws = Sheets("2.0")
' Set the starting position (Top-left most position) of your data range
Set StartCell = ws.Range("A1")

' Turn off autofilter in case it's already active
ws.AutoFilterMode = False
' Define data table
Set rngTable = StartCell.CurrentRegion
' Filter and delete data
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria2
    .Offset(1, 0).EntireRow.Delete
End With
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria6
    .Offset(1, 0).EntireRow.Delete
End With
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria8
    .Offset(1, 0).EntireRow.Delete
End With
' Turn filters off again
ws.AutoFilterMode = False

Set rngTable = Nothing
Set StartCell = Nothing
Set ws = Nothing

问题原因 #

直接使用.Offset(1, 0).EntireRow.Delete时，若筛选无匹配项，该语句会删除表头下方的所有行（无论是否隐藏），导致整表被误删。正确的做法是仅删除筛选后的可见数据行，且在无匹配项时跳过删除操作。

修改后的代码 #

' MACRO TO DELETE SYSTEMATIC USERNAMES
Dim rngTable As Range
Dim ws As Worksheet
Dim StartCell As Range
Dim visibleRows As Range ' 新增变量存储可见行

Const ColumntoFilter1 As Integer = 2
Const FilterCriteria1 As String = "ASH"
Const FilterCriteria2 As String = "HPD"
Const FilterCriteria3 As String = "INQUIRY"
Const FilterCriteria4 As String = "BULKOPS"
Const FilterCriteria5 As String = "AHIN1"
Const FilterCriteria6 As String = "LPXP"
Const FilterCriteria7 As String = "PPI_BATCH"
Const FilterCriteria8 As String = "REPROCESSOR"

' DELETES SYSTEM USERNAMES FROM 1.0 TAB
Set ws = Sheets("1.0")
Set StartCell = ws.Range("A1")

ws.AutoFilterMode = False
Set rngTable = StartCell.CurrentRegion

With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria1
    ' 捕获无可见行时的错误
    On Error Resume Next
    Set visibleRows = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    ' 仅当存在可见行时执行删除
    If Not visibleRows Is Nothing Then
        visibleRows.EntireRow.Delete
        Set visibleRows = Nothing ' 重置变量
    End If
End With
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria2
    On Error Resume Next
    Set visibleRows = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not visibleRows Is Nothing Then
        visibleRows.EntireRow.Delete
        Set visibleRows = Nothing
    End If
End With
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria6
    On Error Resume Next
    Set visibleRows = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not visibleRows Is Nothing Then
        visibleRows.EntireRow.Delete
        Set visibleRows = Nothing
    End If
End With

ws.AutoFilterMode = False
Set rngTable = Nothing
Set StartCell = Nothing
Set ws = Nothing

' DELETES SYSTEM USERNAMES FROM 2.0 TAB
Set ws = Sheets("2.0")
Set StartCell = ws.Range("A1")

ws.AutoFilterMode = False
Set rngTable = StartCell.CurrentRegion

With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria2
    On Error Resume Next
    Set visibleRows = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not visibleRows Is Nothing Then
        visibleRows.EntireRow.Delete
        Set visibleRows = Nothing
    End If
End With
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria6
    On Error Resume Next
    Set visibleRows = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not visibleRows Is Nothing Then
        visibleRows.EntireRow.Delete
        Set visibleRows = Nothing
    End If
End With
With rngTable
    .AutoFilter Field:=ColumntoFilter1, Criteria1:=FilterCriteria8
    On Error Resume Next
    Set visibleRows = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not visibleRows Is Nothing Then
        visibleRows.EntireRow.Delete
        Set visibleRows = Nothing
    End If
End With

ws.AutoFilterMode = False
Set rngTable = Nothing
Set StartCell = Nothing
Set ws = Nothing

关键修改点 #

• 新增visibleRows变量存储筛选后的可见数据行
• 使用SpecialCells(xlCellTypeVisible)仅选中表头下方的可见行
• 加入错误处理，避免无可见行时抛出运行时错误
• 判断visibleRows是否为空，为空则跳过删除操作，直接执行后续代码

内容的提问来源于stack exchange，提问作者ML300