为什么这个 VBA 代码到运行花费的时间太长？

Question

社区成员大家好！

这是一个与VBA代码优化相关的查询，我是初学者，所以我在这方面的经验不多。我目前正在处理用于构建仪表板的 excel 文件，它需要清理电子表格中的数据。因此，我编写了一个非常简单的 VBA 代码，该代码成功运行，但执行时间异常长（40-45 分钟）。我在互联网上对此进行了研究，但找不到解决方案。如果有人可以帮助我优化我创建的 VBA 代码（在下面发布），以便最多需要 5 或 10 分钟来执行或什至更快，我将非常高兴。代码很简单，如果给定条件在列的指定范围内匹配，它会删除整行。预先感谢您的帮助，我将非常感激，因为我是一名从事此项目的学生！

VBA代码：

Sub Dashboard()
Application.ScreenUpdating = False
Dim rng As Range, i As Integer

'Set range to evaluate
Set rng = Range("N8:N10000")

'Loop backwards through the rows in the range to evaluate
For i = rng.Rows.Count To 1 Step -1

'If cell i in the range contains "x", delete the entire row
If rng.Cells(i).Value = "John" Then rng.Cells(i).EntireRow.Delete
Next

'Delete name Tom
Set rng = Range("L8:L10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "TOM" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Blanks
Set rng = Range("L8:L10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next


'Delete Blanks
Set rng = Range("O8:O10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Blanks
Set rng = Range("Q8:Q10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Blanks
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Sara
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "SARA" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Ben
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "BEN" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Meredith
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "MEREDITH" Then rng.Cells(i).EntireRow.Delete
Next

'Delete April
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "APRIL" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Jason
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "JASON" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Sana
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "SANA" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Blanks
Set rng = Range("AJ8:AJ10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next

'Delete June
Set rng = Range("AJ8:AJ10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "JUNE" Then rng.Cells(i).EntireRow.Delete
Next

'Delete October
Set rng = Range("AJ8:AJ10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "OCTOBER" Then rng.Cells(i).EntireRow.Delete
Next

'Delete January
Set rng = Range("AJ8:AJ10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "JANUARY" Then rng.Cells(i).EntireRow.Delete
Next

'Delete Blanks
Set rng = Range("AS8:AS10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next
Application.ScreenUpdating = True
End Sub

Answer 1

减少到只有一个循环

Option Explicit

Public Sub Dashboard()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    'Loop backwards through the rows in the range to evaluate
    Dim i As Long
    For i = 10000 To 8 Step -1
        If Cells(i, "N").Value = "John" Or _
           Cells(i, "L").Value = "TOM" Or _
           Cells(i, "L").Value = vbNullString Or _
           Cells(i, "O").Value = vbNullString Or _
           Cells(i, "Q").Value = vbNullString Or _
           Cells(i, "R").Value = vbNullString Or _
           Cells(i, "R").Value = "SARA" Or _
           Cells(i, "R").Value = "BEN" Or _
           Cells(i, "R").Value = "MEREDITH" Or _
           Cells(i, "R").Value = "APRIL" Or _
           Cells(i, "R").Value = "JASON" Or _
           Cells(i, "R").Value = "SANA" Or _
           Cells(i, "AJ").Value = vbNullString Or _
           Cells(i, "AJ").Value = "JUNE" Or _
           Cells(i, "AJ").Value = "OCTOBER" Or _
           Cells(i, "AJ").Value = "JANUARY" Or _
           Cells(i, "AS").Value = vbNullString Then
            Rows(i).EntireRow.Delete
        End If
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

或者更快：将所有要删除的行收集到一个变量中，最后一次性全部删除：

Option Explicit

Public Sub Dashboard()
    Dim RowsToDelete As Range
    
    'Loop backwards through the rows in the range to evaluate
    Dim i As Long
    For i = 10000 To 8 Step -1
        If Cells(i, "N").Value = "John" Or _
           Cells(i, "L").Value = "TOM" Or _
           Cells(i, "L").Value = vbNullString Or _
           Cells(i, "O").Value = vbNullString Or _
           Cells(i, "Q").Value = vbNullString Or _
           Cells(i, "R").Value = vbNullString Or _
           Cells(i, "R").Value = "SARA" Or _
           Cells(i, "R").Value = "BEN" Or _
           Cells(i, "R").Value = "MEREDITH" Or _
           Cells(i, "R").Value = "APRIL" Or _
           Cells(i, "R").Value = "JASON" Or _
           Cells(i, "R").Value = "SANA" Or _
           Cells(i, "AJ").Value = vbNullString Or _
           Cells(i, "AJ").Value = "JUNE" Or _
           Cells(i, "AJ").Value = "OCTOBER" Or _
           Cells(i, "AJ").Value = "JANUARY" Or _
           Cells(i, "AS").Value = vbNullString Then
           
            ' collect rows we want to delete in RowsToDelete
            If RowsToDelete Is Nothing Then
                Set RowsToDelete = Rows(i).EntireRow
            Else
                Set RowsToDelete = Union(RowsToDelete, Rows(i).EntireRow)
            End If
        End If
    Next
    
    'delete all at once in the end
    If Not RowsToDelete Is Nothing Then
        RowsToDelete.Delete
    End If
End Sub

Answer 2

请尝试下一个代码。它很紧凑，使用单次迭代，一个数组使代码更快，Union 范围保持要删除的行的单元格。这些将被立即删除，在代码末尾：

Sub Dashboard()
 Dim sh As Worksheet, rng As Range, arr, rngDel As Range, rngAdd As Range, i As Long

 Set sh = ActiveSheet
 arr = sh.Range("L1:AS1000").value 'place the range in an array for faster iteration

 For i = 8 To UBound(arr)
    If arr(i, 3) = "John" Or arr(i, 1) = "TOM" Or arr(i, 1) = "" _
        Or arr(i, 4) = "" Or arr(i, 6) = "" Or arr(i, 7) = "" _
        Or arr(i, 7) = "BEN" Or arr(i, 7) = "SARA" Or arr(i, 7) = "MEREDITH" _
        Or arr(i, 7) = "APRIL" Or arr(i, 7) = "JASON" Or arr(i, 7) = "SANA" _
        Or arr(i, 25) = "" Or arr(i, 25) = "JUNE" Or arr(i, 25) = "OCTOBER" _
        Or arr(i, 25) = "JANUARY" Or arr(i, 34) = "" Then
        If rngDel Is Nothing Then
            Set rngDel = sh.Range("A" & i)
        Else
            Set rngDel = Union(rngDel, sh.Range("A" & i))
        End If
    End If
 Next i
 If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub

Answer 3

如果您可以使用辅助列，您可能会受益于一次删除所有行：

Sub Dashboard()
Application.ScreenUpdating = False

With Range("ZZ8:ZZ10000")
    .Formula = "=IF(OR(L8=""TOM"",L8="""",O8="""",Q8="""",R8="""",R8=""SARA"",R8=""BEN"",R8=""MEREDITH"",R8=""APRIL"",R8=""JASON"",R8=""SANA"",AJ8=""""," & _
        "AJ8=""JUNE"",AJ8=""OCTOBER"",AJ8=""JANUARY"",AS8=""""),""X"",1)"
    .SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
    .ClearContents
End Sub

End With

Application.ScreenUpdating = True

End Sub

该代码使用辅助列（在我的代码中是 ZZ，但它可以在任何地方）并键入 IG 的公式（或...您的所有条件）。如果满足这些条件中的任何一个，return "X" else return 1 (numeric value).

公式将根据结果 return 文本或数值。然后，您可以 select 所有包含公式的列中的单元格 return 编辑文本（我们的 X 值）并立即删除所有这些行。

然后代码清除公式并保持一切干净。

这种方法的优点是您根本不需要循环，而是一次性删除所有目标行。但缺点是如果条件经常变化，更新代码部分会很烦人。

来源：

Understanding the syntax of "special cells" in Excel VBA

Range.SpecialCells method (Excel)

Answer 4

一堆`ElseIf` 语句

Sub FixDashboard()
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim lCell As Range
    Set lCell = ws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If lCell Is Nothing Then Exit Sub
    If lCell.Row < 8 Then Exit Sub
    
    Dim drg As Range
    Dim r As Long
    Dim Dont As Boolean
    
    For r = 8 To lCell.Row
        
        If StrComp(CStr(ws.Cells(r, "N").Value), "John", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "L").Value), "Tom", vbTextCompare) = 0 Then
        ElseIf Len(CStr(ws.Cells(r, "L").Value)) = 0 Then
        ElseIf Len(CStr(ws.Cells(r, "O").Value)) = 0 Then
        ElseIf Len(CStr(ws.Cells(r, "Q").Value)) = 0 Then
        ElseIf Len(CStr(ws.Cells(r, "R").Value)) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Sara", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Ben", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Meredith", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "April", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Jason", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Sana", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Tom", vbTextCompare) = 0 Then
        ElseIf Len(CStr(ws.Cells(r, "AJ").Value)) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "AJ").Value), "June", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "AJ").Value), "October", vbTextCompare) = 0 Then
        ElseIf StrComp(CStr(ws.Cells(r, "AJ").Value), "January", vbTextCompare) = 0 Then
        ElseIf Len(CStr(ws.Cells(r, "AS").Value)) = 0 Then
        Else
            Dont = True
        End If
        
        If Not Dont Then
            If drg Is Nothing Then
                Set drg = ws.Cells(r, "A")
            Else
                Set drg = Union(drg, ws.Cells(r, "A"))
            End If
        Else
            Dont = False
        End If
    
    Next r
    
    If drg Is Nothing Then Exit Sub
    
    drg.EntireRow.Delete
    
End Sub

为什么这个 VBA 代码到运行花费的时间太长？

Why does this VBA code take too long to run?

excel

optimization

vba

一堆`ElseIf` 语句

为什么这个 VBA 代码到 运行 花费的时间太长？

Why does this VBA code take too long to run?

excel

optimization

vba

一堆ElseIf 语句

为什么这个 VBA 代码到运行花费的时间太长？

一堆`ElseIf` 语句