有沒有什麼辦法縮短我的代碼中的循環來加速宏？

我是新來的網站，也是寫VBA的新手。我已經嘗試了Macro，它最終成功運行。問題出在宏觀的速度上;即使在一張紙上使用它也很痛苦。我需要複製這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

來源

2016-06-30 Mullak5

如果您的代碼運行，一個更好的地方問這個問題將是http://codereview.stackexchange.com/他們專注於改善和優化工作代碼 – RGA

謝謝，我一定會記住這個未來。我總是嘗試自己完成自己的代碼，因爲經驗是一位優秀的老師 – Mullak5

確實如此！我只是指出你的位置，因爲這些用戶可能更適合幫助你進一步優化。當然，我們很樂意讓像你這樣的成員加入SO社區。快樂的編碼！ – RGA

我在你的訊息給您鏈接到代碼審查，堆棧交換網站，是最適合這種性質的問題，而只是從看你的代碼，有幾個快速簡單的優化可以使。任何經歷相同數據的循環（即對於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 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

爲此在每個循環中，你的代碼應該運行得更快

來源

2016-06-30 09:32:56 RGA

即使命令是相同的，我也離開了'If-ElseIf'結構，因爲（據我所知），通過將所有語句放在一個邏輯檢查中，而OR語句之間沒有性能改進，但它的可能這也可以提高速度。「If-Elseif」只需要儘可能多的條件就可以更容易地閱讀 – RGA

感謝您的迅速回復，我將嘗試實施您的建議並回饋反饋意見。再次感謝 – Mullak5

@ Mullak5看看我所做的編輯，還可以使用'Select Case'語句來縮短你的代碼。 –

有沒有什麼辦法縮短我的代碼中的循環來加速宏？

回答

相關問題