有什么办法缩短我的代码中的循环加快macros？
我是新手，也是写VBA的新手。 我已经在macros观上做了尝试，并且最终成功运行。 问题出在macros观的速度上; 即使在一张纸上使用它也很痛苦。 我需要复制这10页，并运行在每个macros！ 这个问题似乎与For / Next循环，但我没有编码的经验来解决速度问题。 我已经附上了VBA进行检查，任何build议将是最受欢迎的。
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 我评论了你的post，将你链接到codereview，这是一个最适合这种性质问题的堆栈交换站点，但是从查看你的代码，你可以做一些简单而又简单的优化。 任何经历相同数据的循环（即对于r中的每个单元）都不需要重复。 例如，不是使用三次相同的variablesmytext ，而是创build三个不同的mytext#variables，然后适当地使用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 Case”缩短，如下所示：
将条件组合成一个单一的循环，如下所示：
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
在每个循环中执行此操作，并且代码的运行速度要快得多