Excel VBA 自动筛选 > 删除空行

Question

我们有一张用于分析详细招标过程的工作表，并希望删除所有空行。

范围可能因项目而异，最多可能有 170 列和 6000 行。

我测试过的代码在一个大约有 . 40 列和 4750 行，运行只需不到 10 分钟。

寻找任何稍微更优雅的解决方案来缩短这个时间。目前代码会自动过滤每一列的空白，想知道是否即使是被过滤的空列也会减慢整个过程？

在下面的代码中，为了便于查看，我删除了大部分自动过滤字段，但它过滤了 1-175 之间的每个字段。

Sub DeleteEmptyRows()

With Sheets("Detailed Comparison")
    Application.DisplayAlerts = False
    .AutoFilterMode = False
    Application.ScreenUpdating = False

    With .Range("F24:FY6000")
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:="="
        .AutoFilter Field:=2, Criteria1:="="
        .AutoFilter Field:=175, Criteria1:="="
    End With

    With .Range("F25:FY6000").SpecialCells(xlCellTypeVisible).Rows.Delete
    End With

    Application.DisplayAlerts = True

    .AutoFilterMode = False
    Application.ScreenUpdating = True
End With

End Sub

Answer 1

您可以添加一个额外的列，其中包含该行所有非空字段的计数 - 例如=COUNTA(F24:FY24) - 然后过滤该列上 value = 0 的行。

我还没有测试过这个，但猜想它应该更快......

Answer 2

让事情更优雅

1. 当第 1-175 列中的单元格为空白时，添加一个计算结果为 TRUE 的列。过滤此列。

2. 为了更好地定义需要删除的行，请使用函数来定义底行（而不是将底行设置为 6000。

例如：

Function LastRowInOneColumn(ws As Worksheet, Optional bool As Boolean) As Long

'Find the last used row in a Column
'by default, returns row of column A (FLASE)
'if bool is TRUE then will return row of column B

Dim LastRow As Long
Dim col As String

If bool = True Then
    col = "B"
Else
    col = "A"
End If

With ws
    LastRow = .Cells(.Rows.Count, col).End(xlUp).row
End With

LastRowInOneColumn = LastRow

End Function

速度

我建议您测试一下代码的哪一部分运行得如此缓慢。如果是过滤，那么建议 1（上面）应该会有所帮助。如果是删除，则可能是您的工作簿的其他部分正在链接到该数据集，因此在此处删除数据将非常慢。如果是这种情况，我的建议是更改您的其他数据集，以便它们通过您作为 DeleteEmptyRows 宏的第一步删除的命名范围引用此工作表，然后在运行结束时重新创建这些命名范围宏

Sub set_named_ranges()

'creates named ranges needed for this workbook
'this code is somewhat crude, you may need to modify based on how your data are laid out

Dim found As Range
Dim col_lookup_text As String
dim wks_name As String

wks_name = "Detailed Comparison"

Worksheets(wks_name).Select
Worksheets(wks_name).Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select

'header named range
ActiveWorkbook.Names.Add _
        Name:=("data_Header"), _
        RefersTo:=Range(wks_name & "!" & RngAddress(Selection))

'main data named range
Range(Selection, Selection.End(xlDown)).Select

ActiveWorkbook.Names.Add _
        Name:=("dataset"), _
        RefersTo:=Range(wks_name & "!" & RngAddress(Selection))

End Sub

Function RngAddress(rng As Range) As String
RngAddress = rng.Address
End Function

和：

Sub delete_these_named_ranges(ParamArray names_of_named_ranges() As Variant)

'not a very sexy macro
'feed macro names of named ranges
'deletes the named range
'if named range doesn't exist, it creates a named range with
'that name and deletes it to avoid errors

Dim nName As Variant

For Each nName In names_of_named_ranges

    On Error Resume Next
    ActiveWorkbook.Names.Add Name:=nName, RefersTo:="temp"
    ActiveWorkbook.Names(nName).Delete

Next nName

End Sub