有没有办法缩短我的代码中的循环来加速宏？

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

在每个循环中执行此操作，您的代码应该运行得更快

您还可以缩短＆＃34;选择案例＆＃34;，如下所示：

将条件组合成一个循环，如下所示：

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

在每个循环中执行此操作，您的代码应该运行得更快