Excel VBA问题：删除特定文本行与6单元格填充行间的空行

我需要删除包含文本“Cable Length*”的行与包含6个已填充单元格的行之间的所有空行。工作表受保护，用户无法在这两行之间的行中填充超过4个单元格，因此流程是先取消保护工作表→删除空行→重新保护工作表。但我编写的代码存在bug：无法删除所有空行，仅能删除2个，其余无法删除。

原代码如下：

Sub Delete_Empty_Rows()
'BUG: It will not delete all of the empty cells. It will delete 2, but not the rest.

'Prevents screen flashing while the code is going
 Application.ScreenUpdating = False 
 
'To unprotect the sheet
 ActiveSheet.Unprotect Password:="Something"

'Top Boundary of the range is determined by finding "Cable Length(ft)*"
Cells.Find(What:="Cable Length(ft)*", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True _
    , SearchFormat:=False).Activate

'Bottom Boundary of the range is determined by CountA > 5
Do Until WorksheetFunction.CountA(ActiveCell.EntireRow) > 5
    ActiveCell.Offset(1).EntireRow.Activate
    If WorksheetFunction.CountA(ActiveCell.EntireRow) = 0 Then
        ActiveCell.EntireRow.Delete
    End If
Loop

'To protect the sheet
 ActiveSheet.Protect Password:="Something"

'Re-enables screen updating
Application.ScreenUpdating = True

End Sub

问题原因 #

1. 正向循环删除行导致漏删：当你删除一行后，下方的行自动上移，但代码仍执行Offset(1)往下跳转，直接跳过了刚移上来的那一行，导致部分空行没被检查到。
2. 依赖Activate操作不稳定：激活单元格的操作容易因工作表状态变化出现意外，且代码可读性差。

修正后的代码 #

Sub Delete_Empty_Rows()
    ' 关闭屏幕刷新，提升运行效率
    Application.ScreenUpdating = False
    
    ' 取消工作表保护
    ActiveSheet.Unprotect Password:="Something"
    
    Dim topRow As Range
    Dim currentRow As Range
    Dim isBottomRowFound As Boolean
    
    ' 定位包含目标文本的行，去掉After参数避免依赖当前激活单元格
    Set topRow = Cells.Find(What:="Cable Length(ft)*", LookIn:=xlValues, LookAt:=xlWhole, _
        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
    
    ' 确保找到目标行再执行后续操作
    If Not topRow Is Nothing Then
        Set currentRow = topRow.Offset(1) ' 从目标行的下一行开始检查
        isBottomRowFound = False
        
        Do Until isBottomRowFound
            ' 判断是否到达结束行（填充单元格数>5）
            If WorksheetFunction.CountA(currentRow.EntireRow) > 5 Then
                isBottomRowFound = True
            Else
                ' 检查当前行是否为空行
                If WorksheetFunction.CountA(currentRow.EntireRow) = 0 Then
                    ' 删除空行后，currentRow自动指向新的当前行（原下一行上移）
                    currentRow.EntireRow.Delete
                Else
                    ' 非空行则移动到下一行
                    Set currentRow = currentRow.Offset(1)
                End If
            End If
        Loop
    End If
    
    ' 重新保护工作表
    ActiveSheet.Protect Password:="Something"
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
End Sub

关键修改点 #

• 用Range对象替代Activate操作，避免激活单元格带来的不稳定问题，代码更健壮
• 删除空行后不移动currentRow，因为删除行后下方行上移，currentRow会自动指向新的当前行，确保所有行都被检查
• 增加了对topRow是否存在的判断，避免找不到目标文本时触发错误
• 移除After:=ActiveCell参数，避免依赖当前激活的单元格位置，查找逻辑更可靠

内容的提问来源于stack exchange，提问作者Michael Jose Ortiz Gutierrez