我有一张近 100000 行和列 A 到 Q 的工作表 我有一个代码，如果 Q 列有空白单元格，则删除整行。
我已经在 4000 行上尝试过这段代码，它在 3 分钟内运行，但当我处理 100000 行时，它只处理几个小时。
如果有人帮助/指导我加快这段代码，我将非常高兴。
代码是：
Sub DeleteBlank()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lo As ListObject
set lo = sheets("BOM 6061").ListObjects(1)
Sheets("BOM 6061").Activate
lo.AutoFilter.ShowAllData
lo.range.AutoFilter Field:=17, Criteria1:=""
Application.DisplayAlerts = False
Application.Calculation = xlCalculationAutomatic
lo.DataBodyRange.SpecialCells(xlCellsTypeVisible).Delete
Application.DisplayAlerts = True
lo.AutoFilter.ShowAllData
End Sub
Option Explicit
Sub DeleteBlankRows()
Const wsName As String = "BOM 6061"
Const tblIndex As Variant = 1
Const CriteriaColumnNumber As Long = 17
Const Criteria As String = ""
' Reference the table.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(tblIndex)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Remove any filters.
If tbl.ShowAutoFilter Then
If tbl.AutoFilter.FilterMode Then tbl.AutoFilter.ShowAllData
Else
tbl.ShowAutoFilter = True
End If
' Add a helper column and write an ascending integer sequence to it.
Dim lc As ListColumn: Set lc = tbl.ListColumns.Add
lc.DataBodyRange.Value = _
ws.Evaluate("ROW(1:" & lc.DataBodyRange.Rows.Count & ")")
' Sort the criteria column ascending.
With tbl.Sort
.SortFields.Clear
.SortFields.Add2 tbl.ListColumns(CriteriaColumnNumber).Range, _
Order:=xlAscending
.Header = xlYes
.Apply
End With
' AutoFilter.
tbl.Range.AutoFilter Field:=CriteriaColumnNumber, Criteria1:=Criteria
' Reference the filtered (visible) range.
Dim svrg As Range
On Error Resume Next
Set svrg = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Remove the filter.
tbl.AutoFilter.ShowAllData
' Delete the referenced filtered (visible) range.
If Not svrg Is Nothing Then svrg.Delete
' Sort the helper column ascending.
With tbl.Sort
.SortFields.Clear
.SortFields.Add2 lc.Range, Order:=xlAscending
.Header = xlYes
.Apply
.SortFields.Clear
End With
' Delete the helper column.
lc.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' Inform.
MsgBox "Blanks deleted.", vbInformation
End Sub
我不会在大型数据集上使用自动过滤器，因为在实际过滤数据之前，它们可能需要花费相当多的时间来尝试枚举可用选项。 AutoFilter.ShowAllData 花费同样多的时间。对于我的超级简单测试数据集（由 26 列、1000000 行组成），每个数据集的处理时间超过 30 秒。
据我所知，您正在过滤列表以仅显示空白项目，然后删除空白行。由于过滤是导致延迟的原因，我们可以循环遍历每一行，查看特定列，如果它为空，您可以将其删除。以下是如何执行此操作的示例。
**编辑：经过测试，我发现这比您想要的要慢得多。查看下面的下一个示例，因为它非常快。
Option Explicit
Sub DeleteBlank()
Application.ScreenUpdating = False
Dim calcType As Integer
Dim rowCount, columnNumToCheck, currow, dataStartRow As Long
Dim WkSht As String
Dim lo As ListObject
WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
columnNumToCheck = 17 'The column number to check for blank cells.
calcType = Application.Calculation
Application.Calculation = xlCalculationManual
Set lo = Sheets(WkSht).ListObjects(1)
rowCount = lo.ListRows.Count
dataStartRow = (lo.DataBodyRange.Row - 1)
For currow = rowCount To 1 Step -1
If Sheets(WkSht).Cells((currow + dataStartRow), columnNumToCheck).Value = "" Then
Call DeleteRows(WkSht, (currow + dataStartRow))
End If
Next currow
Application.Calculation = calcType
Application.ScreenUpdating = True
End Sub
Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)
If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
optionalEndRow = startRow
End If
Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp
End Sub
如果您能够对空白单元格都在一起的数据进行排序，您可以使用下面的命令来执行单个删除功能，一次将它们全部删除。这在几秒钟内删除了 70000 行。
Sub DeleteBlankWithSort()
'Application.ScreenUpdating = False
Dim columnNumToCheck, tableLastRow, lrow As Long
Dim calcType As Integer
Dim WkSht As String
Dim lo As ListObject
WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
columnNumToCheck = 17 'The column number to check for blank cells.
calcType = Application.Calculation
Application.Calculation = xlCalculationManual
Set lo = Sheets(WkSht).ListObjects(1)
tableLastRow = FindLastRow(WkSht, (columnNumToCheck))
With lo.Sort
.SortFields.Clear
.SortFields.Add _
Key:=Range("Table1[[#All],[q]]"), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lrow = FindLastRow(WkSht, (columnNumToCheck), (tableLastRow))
Call DeleteRows(WkSht, (tableLastRow), (lrow + 1))
Application.Calculation = calcType
Application.ScreenUpdating = True
End Sub
Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)
If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
optionalEndRow = startRow
End If
Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp
End Sub
Private Function FindLastRow(sheetNameIn As String, columnNum As Long, Optional optionalStartRow As Long) As Long
'finds the last row of the column passed in the sheetname passed in
If IsNull(optionalStartRow) Or optionalStartRow = 0 Then
optionalStartRow = 1048576
End If
FindLastRow = Worksheets(sheetNameIn).Range(Cells(optionalStartRow, columnNum).Address).End(xlUp).Row
End Function
不久前我有一个简单的例子。高级过滤是就地过滤或在 excel/vba 中过滤和复制的最快方法。在高级过滤中，您通常会在列/行中列出过滤器，并且可以根据需要设置多个过滤器，使用 >"" 过滤掉列上的空白，应该不需要任何时间。在我的示例中，它可能有所不同，因为如果过滤器中添加了任何内容，则它与sheetchange一起使用以自动过滤。
Sub Advanced_Filtering_ModV2()
Dim rc As Long, crc As Long, trc As Long
Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook: Set ws = wb.Worksheets("sheet1")
ws.Range("AA1").Value = ws.Range("Q1").Value: ws.Range("AA2").Value = ">"""""
On Error Resume Next
ws.ShowAllData: rc = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A1:V" & rc).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=ws.Range("AA1:AA2")
On Error GoTo 0
End Sub