有没有办法缩短代码中的循环以加快宏的速度？

Question

我是新的网站，也是新的写作VBA。我尝试了一下宏，它最终还是成功地运行了。这个问题是随着宏的速度而产生的；即使在一张纸上使用它，它也是非常缓慢的。我需要在10张纸上复制这一点，并在每个表上运行宏！问题似乎与For/Next循环有关，但我没有解决速度问题的编码经验。我已附上VBA以供查阅，如有任何意见，欢迎你提出。

Sub Cloud_Sales()

Dim Firstrow As Long
Dim LastRow As Long
Dim LRow As Long
Dim wb As Workbook
Dim ws As Worksheet

With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
Worksheets("Cloud Sales").Activate
With Sheets("Cloud Sales")

    'Set the first and last row to loop through
    Firstrow = .UsedRange.Cells(1).Row
    LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

    'We loop from Lastrow to Firstrow (bottom to top)
    For LRow = LastRow To Firstrow Step -1

        'We check the values in the N column
        With .Cells(LRow, "N")

           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Unsuccessful") Then .EntireRow.Delete
                'This will delete each row with the Value "Unsuccessful"
                'in Column N.
            End If
        End With

    Next LRow

    For LRow = LastRow To Firstrow Step -1

        'We check the values in the N
        With .Cells(LRow, "N")

           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Not Evaluated") Then .EntireRow.Delete
                'This will delete each row with the Value "Not Evaluated"
                'in Column N.
            End If
        End With

    Next LRow

    For LRow = LastRow To Firstrow Step -1

        'We check the values in the N
        With .Cells(LRow, "N")

           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Suspended") Then .EntireRow.Delete
                'This will delete each row with the Value "Suspended"
                'in Column N.
            End If
        End With

    Next LRow

    'We loop from Lastrow to Firstrow (bottom to top)
    For LRow = LastRow To Firstrow Step -1

        'We check the values in the L column
        With .Cells(LRow, "L")

           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("North America") Then .EntireRow.Delete
                'This will delete each row with the Value "North America"
                'in Column L.
            End If
        End With

    Next LRow

    For LRow = LastRow To Firstrow Step -1

        'We check the values in the L
        With .Cells(LRow, "L")

           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Latin America") Then .EntireRow.Delete
                'This will delete each row with the Value "Latin America"
                'in Column L.
            End If
        End With

    Next LRow

    For LRow = LastRow To Firstrow Step -1

        'We check the values in the L
        With .Cells(LRow, "L")

           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("APJ") Then .EntireRow.Delete
                'This will delete each row with the Value "APJ"
                'in Column L.
            End If
        End With

    Next LRow

    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency 2016 Post-class Test - Chinese") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency 2016 Post-class Test - Chinese"
                'in Column E.
            End If
        End With
     Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency 2016 Post-class Test - Japanese") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency 2016 Post-class Test - Japanese"
                'in Column E.
            End If
        End With
      Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency 2016 Post-class Test - Korean") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency 2016 Post-class Test - Korean"
                'in Column E.
            End If
        End With
      Next LRow


     For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency 2016 Workshop - AM") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency 2016 Workshop - AM"
                'in Column E.
            End If
        End With
     Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
            If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency 2016 Workshop - ILT") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency 2016 Workshop - ILT"
                'in Column E.
            End If
         End With
     Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency 2016 Workshop - LA") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency 2016 Workshop - LA"
                'in Column E.
            End If
        End With
     Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency 2016 Workshop Attendance Verification - APJ") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency 2016 Workshop Attendance Verification - APJ"
                'in Column E.
            End If
        End With
    Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency Prework - Chinese") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency Prework - Chinese"
                'in Column E.
            End If
        End With
    Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency Prework - Japanese") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency Prework - Japanese"
                'in Column E.
            End If
        End With
    Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("Sales Cloud Competency Prework - Korean") Then .EntireRow.Delete
                'This will delete each row with the Value "Sales Cloud Competency Prework - Korean"
                'in Column E.
            End If
        End With
    Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("VMAX 101 - Chinese") Then .EntireRow.Delete
                'This will delete each row with the Value "VMAX 101 - Chinese"
                'in Column E.
            End If
        End With
    Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("VMAX 101 - Japanese") Then .EntireRow.Delete
                'This will delete each row with the Value "VMAX 101 - Japanese"
                'in Column E.
            End If
        End With
    Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("VMAX 101 - Korean") Then .EntireRow.Delete
                'This will delete each row with the Value "VMAX 101 - Korean"
                'in Column E.
            End If
        End With
     Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("XtremIO 101 - Chinese") Then .EntireRow.Delete
                'This will delete each row with the Value "XtremIO 101 - Chinese"
                'in Column E.
            End If
        End With
     Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
            If Not IsError(.Value) Then
                If LCase(.Value) = LCase("XtremIO 101 - Japanese") Then .EntireRow.Delete
                'This will delete each row with the Value "XtremIO 101 - Japanese"
                'in Column E.
            End If
        End With
     Next LRow


    For LRow = LastRow To Firstrow Step -1
        'We check the values in the E
        With .Cells(LRow, "E")
           If Not IsError(.Value) Then
                If LCase(.Value) = LCase("XtremIO 101 - Korean") Then .EntireRow.Delete
                'This will delete each row with the Value "XtremIO 101 - Korean"
                'in Column E.
            End If
        End With
     Next LRow

End With

'This will copy and paste Column E and insert into a new column P,maintaining header formatting
Columns("E:E").Select
Selection.Copy
Columns("P:P").Select
ActiveSheet.Paste
Range("Table1[[#Headers],[Course Title]]").Select
Application.CutCopyMode = False
Selection.Copy
Range("P1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False


'This will change the multiple values for each Course Title to one specific title
        Set r = Range("P:P")
        mytext = "Sales Cloud Competency 2016 Post-class Test"

For Each cell In r
        If cell.Value = "Sales Cloud Competency 2016 Post-class Test - English" Then
            cell.Value = mytext
        ElseIf cell.Value = "Sales Cloud Competency 2016 Post-class Test - French" Then
            cell.Value = mytext
        ElseIf cell.Value = "Sales Cloud Competency 2016 Post-class Test - German" Then
            cell.Value = mytext
        ElseIf cell.Value = "Sales Cloud Competency 2016 Post-class Test - Russian" Then
            cell.Value = mytext
        End If

    Next
        Set r = Range("P:P")
        mytext = "Sales Cloud Competency 2016 Workshop"

For Each cell In r
        If cell.Value = "Sales Cloud Competency 2016 Workshop - EM" Then
            cell.Value = mytext
        ElseIf cell.Value = "Sales Cloud Competency 2016 Workshop - ILT" Then
        End If

    Next
        Set r = Range("P:P")
        mytext = "Sales Cloud Competency Prework"

For Each cell In r
        If cell.Value = "Sales Cloud Competency Prework - English" Then
            cell.Value = mytext
        ElseIf cell.Value = "Sales Cloud Competency Prework - French" Then
            cell.Value = mytext
        ElseIf cell.Value = "Sales Cloud Competency Prework - German" Then
            cell.Value = mytext
        ElseIf cell.Value = "Sales Cloud Competency Prework - Russian" Then
            cell.Value = mytext
        End If

    Next
        Set r = Range("P:P")
        mytext = "VMAX 101"

For Each cell In r
        If cell.Value = "VMAX 101 - English" Then
            cell.Value = mytext
        ElseIf cell.Value = "VMAX 101 - French" Then
            cell.Value = mytext
        ElseIf cell.Value = "VMAX 101 - German" Then
            cell.Value = mytext
        ElseIf cell.Value = "VMAX 101 - Russian" Then
            cell.Value = mytext
        End If

    Next
        Set r = Range("P:P")
        mytext = "XtremIO 101"

For Each cell In r
        If cell.Value = "XtremIO 101 - English" Then
            cell.Value = mytext
        ElseIf cell.Value = "XtremIO 101 - French" Then
            cell.Value = mytext
        ElseIf cell.Value = "XtremIO 101 - German" Then
            cell.Value = mytext
        ElseIf cell.Value = "XtremIO 101 - Russian" Then
            cell.Value = mytext
        End If

    Next

    'Remove duplicates from "Learner Email Address" & "Course Title2" columns
    Range("P2").Select
    ActiveSheet.Range("Table1[#All]").RemoveDuplicates Columns:=Array(10, 16), _
    Header:=xlYes

    'Resize Raw Data table to add in new Column P to table in order to refresh Pivot
    Worksheets("Cloud Sales").ListObjects("Table1").Resize Range("$A:$P")

    'Hide Raw Data tab, open pivot table tab

        Worksheets("Cloud Sales").Visible = False
        Worksheets("Cloud Sales Pivot").Visible = True
        Worksheets("Cloud Sales Pivot").Activate

    ' Create Pivot Table
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
    "Cloud Sales!R1C1:R1048576C16", Version:=xlPivotTableVersion15). _
    CreatePivotTable TableDestination:="Cloud Sales Pivot!R2C2", TableName:= _
    "PivotTable1", DefaultVersion:=xlPivotTableVersion15
    Sheets("Cloud Sales Pivot").Select
    Cells(2, 2).Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Course Title2")
    .Orientation = xlColumnField
    .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
    "Learner Main Geography")
    .Orientation = xlPageField
    .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Learner Email Address" _
    )
    .Orientation = xlRowField
    .Position = 1
End With
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
    "PivotTable1").PivotFields("Course Title2"), "Count of Course Title2", xlCount

   'Inform the user that the process has successfully completed

      MsgBox "Cloud Sales Complete", vbOKOnly, "Success"

End Sub

Answer 1

我在您的帖子中发表评论，将您链接到codereview，这是一个最适合此类问题的堆栈交换站点，但是只要查看您的代码，就可以进行一些快速而简单的优化。正在经历相同数据的任何循环(即对于r中的每个单元)都不需要重复。例如，与其三次使用相同的变量mytext，不如创建三个不同的mytext#变量，然后适当地使用If条件。这样，您的代码只在范围内运行一次，但会进行所有适当的更改。对于代码的第一部分中的每一个行删除，也可以这样做。

我将给出一个例子，说明如何改进这一点，因此这个过程应该足够简单，可以遵循。而不是：

For LRow = LastRow To Firstrow Step -1

    'We check the values in the N column
    With .Cells(LRow, "N")

       If Not IsError(.Value) Then
            If LCase(.Value) = LCase("Unsuccessful") Then .EntireRow.Delete
            'This will delete each row with the Value "Unsuccessful"
            'in Column N.
        End If
    End With

Next LRow

For LRow = LastRow To Firstrow Step -1

    'We check the values in the N
    With .Cells(LRow, "N")

       If Not IsError(.Value) Then
            If LCase(.Value) = LCase("Not Evaluated") Then .EntireRow.Delete
            'This will delete each row with the Value "Not Evaluated"
            'in Column N.
        End If
    End With

Next LRow

For LRow = LastRow To Firstrow Step -1

    'We check the values in the N
    With .Cells(LRow, "N")

       If Not IsError(.Value) Then
            If LCase(.Value) = LCase("Suspended") Then .EntireRow.Delete
            'This will delete each row with the Value "Suspended"
            'in Column N.
        End If
    End With

Next LRow

将条件合并到一个循环中，如下所示：

For LRow = LastRow To Firstrow Step -1
     With .Cells(LRow, "N")
       If Not IsError(.Value) Then
            If LCase(.Value) = LCase("Suspended") Then 
            .EntireRow.Delete
            'This will delete each row with the Value "Suspended"
            'in Column N.
            ElseIf LCase(.Value) = LCase("Not Evaluated") Then
             .EntireRow.Delete
            'This will delete each row with the Value "Not Evaluated"
            'in Column N.
            ElseIf LCase(.Value) = LCase("Unsuccessful") Then 
            .EntireRow.Delete
            'This will delete each row with the Value "Unsuccessful"
            'in Column N.
            End If
        End If
    End With
Next LRow

在每个循环中这样做，您的代码应该运行得更快。

您也可以使用"Select“缩短，如下所示：

将条件合并到一个循环中，如下所示：

For LRow = LastRow To Firstrow Step -1
    With .Cells(LRow, "N")
       If Not IsError(.Value) Then
           Select Case LCase(.Value)
               Case LCase("Suspended")
                   .EntireRow.Delete
                'This will delete each row with the Value "Suspended"
                'in Column N.
               Case LCase("Not Evaluated")
                   .EntireRow.Delete
                   'This will delete each row with the Value "Not Evaluated"
                   'in Column N.
               Case LCase("Unsuccessful") 
                   .EntireRow.Delete
                   'This will delete each row with the Value "Unsuccessful"
                   'in Column N.
           End Select
        End If
    End With
Next LRow

或者，即使所有情况都有相同的程序，也可以使用：

For LRow = LastRow To Firstrow Step -1
    With .Cells(LRow, "N")
       If Not IsError(.Value) Then
           Select Case LCase(.Value)
               Case LCase("Suspended"), LCase("Not Evaluated"), LCase("Unsuccessful")       
                   .EntireRow.Delete
                   'This will delete each row with the Value "Suspended"
                   'in Column N.
            End Select
        End If
    End With
Next LRow

在每个循环中这样做，您的代码应该运行得更快。