VBA代碼滯後 - 我如何加快它？

Question

任何幫助將不勝感激

我有以下代碼，通過工作簿1上的工作簿查看某個名稱（例如，SheetA，Sheetb等）。表單匹配後，如果某個關鍵字在選定表單上匹配，它將開始從工作簿1的工作表中複製值並將其粘貼到工作簿2中。

我希望工作簿1中的數據寫入現有數據工作簿2，而不是覆蓋，這是它在做什麼。不過，我的代碼現在正在逐一進行復制/粘貼。

有人告訴我，我可以加快它，如果我保存的值到變量，並寫入到細胞中，但我不知道如何去了解它

Public Sub Validation() 
    Dim ws As Worksheet 
    Dim iCounter As Long 
    Dim wkb1 As Workbook 
    Dim wkb2 As Workbook 
    Dim ws1 As Worksheet 
    Dim rw As Long 
    Dim rw1 As Long 
    Dim rw2 As Long 
    Dim rw3 As Long 
    Dim rw4 As Long 
    Dim lastrow As Long 
    Dim WS2 As Worksheet 
    Dim ws3 As Worksheet 
    Dim ws4 As Worksheet 
    Dim ws5 As Worksheet 
    Dim ws6 As Worksheet 

    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 

    Set wkb2 = Workbooks.Open("workbook2xlsx") 
    Set WS2 = wkb2.Sheets("sheeta") 
    Set ws3 = wkb2.Sheets("sheetb") 
    Set ws4 = wkb2.Sheets("sheetc") 
    Set ws5 = wkb2.Sheets("sheetd") 
    Set ws6 = wkb2.Sheets("sheetf") 
    rw = WS2.Cells(WS2.Rows.Count, "A").End(xlUp).Row + 1 
    rw1 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row + 1 
    rw2 = ws4.Cells(ws4.Rows.Count, "A").End(xlUp).Row + 1 
    rw3 = ws5.Cells(ws5.Rows.Count, "A").End(xlUp).Row + 1 
    rw4 = ws6.Cells(ws6.Rows.Count, "A").End(xlUp).Row + 1 

    Set wkb1 = ThisWorkbook 
    wkb1.Activate 

    For Each ws In ActiveWorkbook.Worksheets 
     If ws.Name Like "*" & "sheeta" & "*" Then 
      ws.Select 
      If ws.Cells(5, 2).Value = "COMPLETE" Then 
       Cells(9, 1).Copy 
       WS2.Cells(rw, 1).PasteSpecial Paste:=xlPasteValues 
       Cells(29, 2).Copy 
       WS2.Cells(rw, 2).PasteSpecial Paste:=xlPasteValues 
       Cells(29, 3).Copy 
       WS2.Cells(rw, 3).PasteSpecial Paste:=xlPasteValues 
       Cells(15, 1).Copy 
       WS2.Cells(rw, 4).PasteSpecial Paste:=xlPasteValues 
       Cells(39, 1).Copy 
       WS2.Cells(rw, 5).PasteSpecial Paste:=xlPasteValues 
       Cells(39, 2).Copy 
       WS2.Cells(rw, 6).PasteSpecial Paste:=xlPasteValues 
       Cells(39, 3).Copy 
       WS2.Cells(rw, 7).PasteSpecial Paste:=xlPasteValues 
       Cells(55, 1).Copy 
       WS2.Cells(rw, 8).PasteSpecial Paste:=xlPasteValues 
       Cells(55, 2).Copy 
       WS2.Cells(rw, 9).PasteSpecial Paste:=xlPasteValues 
       Cells(55, 3).Copy 
       WS2.Cells(rw, 10).PasteSpecial Paste:=xlPasteValues 
       Cells(55, 4).Copy 
       WS2.Cells(rw, 11).PasteSpecial Paste:=xlPasteValues 

       Cells(57, 1).Copy 
       WS2.Cells(rw, 12).PasteSpecial Paste:=xlPasteValues 
       Cells(57, 2).Copy 
       WS2.Cells(rw, 13).PasteSpecial Paste:=xlPasteValues 
       Cells(57, 3).Copy 
       WS2.Cells(rw, 14).PasteSpecial Paste:=xlPasteValues 
       Cells(57, 4).Copy 
       WS2.Cells(rw, 15).PasteSpecial Paste:=xlPasteValues 
       Cells(59, 1).Copy 
       WS2.Cells(rw, 16).PasteSpecial Paste:=xlPasteValues 
       Cells(59, 2).Copy 
       WS2.Cells(rw, 17).PasteSpecial Paste:=xlPasteValues 
       Cells(59, 3).Copy 
       WS2.Cells(rw, 18).PasteSpecial Paste:=xlPasteValues 
       Cells(59, 4).Copy 
       WS2.Cells(rw, 19).PasteSpecial Paste:=xlPasteValues 

       Cells(61, 1).Copy 
       WS2.Cells(rw, 20).PasteSpecial Paste:=xlPasteValues 
       Cells(61, 2).Copy 
       WS2.Cells(rw, 21).PasteSpecial Paste:=xlPasteValues 
       Cells(3, 2).Copy 
       WS2.Cells(rw, 22).PasteSpecial Paste:=xlPasteValues 
       Cells(4, 2).Copy 
       WS2.Cells(rw, 23).PasteSpecial Paste:=xlPasteValues 

      End If 

     End If 

     If ws.Name Like "*" & "sheetb" & "*" Then 
      ws.Select 
      If ws.Cells(5, 2).Value = "COMPLETE" Then 

       Cells(9, 1).Copy 
       ws3.Cells(rw1, 1).PasteSpecial Paste:=xlPasteValues 
       Cells(9, 2).Copy 
       ws3.Cells(rw1, 2).PasteSpecial Paste:=xlPasteValues 
       Cells(26, 1).Copy 
       ws3.Cells(rw1, 3).PasteSpecial Paste:=xlPasteValues 
       Cells(14, 1).Copy 
       ws3.Cells(rw1, 4).PasteSpecial Paste:=xlPasteValues 
       Cells(26, 2).Copy 
       ws3.Cells(rw1, 5).PasteSpecial Paste:=xlPasteValues 
       Cells(26, 3).Copy 
       ws3.Cells(rw1, 6).PasteSpecial Paste:=xlPasteValues 
       Cells(30, 4).Copy 
       ws3.Cells(rw1, 7).PasteSpecial Paste:=xlPasteValues 
       Cells(32, 4).Copy 
       ws3.Cells(rw1, 8).PasteSpecial Paste:=xlPasteValues 

       Cells(46, 1).Copy 
       ws3.Cells(rw1, 9).PasteSpecial Paste:=xlPasteValues 
       Cells(46, 2).Copy 
       ws3.Cells(rw1, 10).PasteSpecial Paste:=xlPasteValues 
       Cells(46, 3).Copy 
       ws3.Cells(rw1, 11).PasteSpecial Paste:=xlPasteValues 
       Cells(46, 4).Copy 
       ws3.Cells(rw1, 12).PasteSpecial Paste:=xlPasteValues 

       Cells(48, 1).Copy 
       ws3.Cells(rw1, 13).PasteSpecial Paste:=xlPasteValues 
       Cells(48, 2).Copy 
       ws3.Cells(rw1, 14).PasteSpecial Paste:=xlPasteValues 
       Cells(48, 3).Copy 
       ws3.Cells(rw1, 15).PasteSpecial Paste:=xlPasteValues 
       Cells(48, 4).Copy 
       ws3.Cells(rw1, 16).PasteSpecial Paste:=xlPasteValues 

       Cells(50, 1).Copy 
       ws3.Cells(rw1, 17).PasteSpecial Paste:=xlPasteValues 
       Cells(50, 2).Copy 
       ws3.Cells(rw1, 18).PasteSpecial Paste:=xlPasteValues 
       Cells(50, 3).Copy 
       ws3.Cells(rw1, 19).PasteSpecial Paste:=xlPasteValues 
       Cells(50, 4).Copy 
       ws3.Cells(rw1, 20).PasteSpecial Paste:=xlPasteValues 

       Cells(52, 4).Copy 
       ws3.Cells(rw1, 21).PasteSpecial Paste:=xlPasteValues 

       Cells(3, 2).Copy 
       ws3.Cells(rw1, 22).PasteSpecial Paste:=xlPasteValues 
       Cells(4, 2).Copy 
       ws3.Cells(rw1, 23).PasteSpecial Paste:=xlPasteValues 

      End If 
     End If 

     If ws.Name Like "*" & "sheetc" & "*" Then 
      ws.Select 
      If ws.Cells(5, 2).Value = "COMPLETE" Then 

       Cells(9, 1).Copy 
       ws4.Cells(rw2, 1).PasteSpecial Paste:=xlPasteValues 
       Cells(9, 3).Copy 
       ws4.Cells(rw2, 2).PasteSpecial Paste:=xlPasteValues 
       Cells(9, 2).Copy 
       ws4.Cells(rw2, 3).PasteSpecial Paste:=xlPasteValues 
       Cells(23, 1).Copy 
       ws4.Cells(rw2, 4).PasteSpecial Paste:=xlPasteValues 
       Cells(19, 2).Copy 
       ws4.Cells(rw2, 5).PasteSpecial Paste:=xlPasteValues 
       Cells(19, 3).Copy 
       ws4.Cells(rw2, 6).PasteSpecial Paste:=xlPasteValues 
       Cells(13, 1).Copy 
       ws4.Cells(rw2, 7).PasteSpecial Paste:=xlPasteValues 
       Cells(13, 2).Copy 
       ws4.Cells(rw2, 8).PasteSpecial Paste:=xlPasteValues 

       Cells(33, 1).Copy 
       ws4.Cells(rw2, 9).PasteSpecial Paste:=xlPasteValues 
       Cells(33, 2).Copy 
       ws4.Cells(rw2, 10).PasteSpecial Paste:=xlPasteValues 
       Cells(33, 3).Copy 
       ws4.Cells(rw2, 11).PasteSpecial Paste:=xlPasteValues 
       Cells(33, 4).Copy 
       ws4.Cells(rw2, 12).PasteSpecial Paste:=xlPasteValues 

       Cells(35, 1).Copy 
       ws4.Cells(rw2, 13).PasteSpecial Paste:=xlPasteValues 
       Cells(35, 2).Copy 
       ws4.Cells(rw2, 14).PasteSpecial Paste:=xlPasteValues 
       Cells(35, 3).Copy 
       ws4.Cells(rw2, 15).PasteSpecial Paste:=xlPasteValues 
       Cells(35, 4).Copy 
       ws4.Cells(rw2, 16).PasteSpecial Paste:=xlPasteValues 

       Cells(37, 1).Copy 
       ws4.Cells(rw2, 17).PasteSpecial Paste:=xlPasteValues 
       Cells(37, 2).Copy 
       ws4.Cells(rw2, 18).PasteSpecial Paste:=xlPasteValues 
       Cells(37, 3).Copy 
       ws4.Cells(rw2, 19).PasteSpecial Paste:=xlPasteValues 
       Cells(37, 4).Copy 
       ws4.Cells(rw2, 20).PasteSpecial Paste:=xlPasteValues 

       Cells(39, 4).Copy 
       ws4.Cells(rw2, 21).PasteSpecial Paste:=xlPasteValues 

       Cells(3, 2).Copy 
       ws4.Cells(rw2, 22).PasteSpecial Paste:=xlPasteValues 
       Cells(4, 2).Copy 
       ws4.Cells(rw2, 23).PasteSpecial Paste:=xlPasteValues 

      End If 
     End If 

     If ws.Name Like "*" & "sheetd" & "*" Then 
      ws.Select 
      If ws.Cells(5, 2).Value = "COMPLETE" Then 

       Cells(9, 1).Copy 
       ws5.Cells(rw3, 1).PasteSpecial Paste:=xlPasteValues 
       Cells(9, 2).Copy 
       ws5.Cells(rw3, 2).PasteSpecial Paste:=xlPasteValues 
       Cells(9, 4).Copy 
       ws5.Cells(rw3, 3).PasteSpecial Paste:=xlPasteValues 
       Cells(13, 1).Copy 
       ws5.Cells(rw3, 4).PasteSpecial Paste:=xlPasteValues 
       Cells(13, 2).Copy 
       ws5.Cells(rw3, 5).PasteSpecial Paste:=xlPasteValues 
       Cells(13, 3).Copy 
       ws5.Cells(rw3, 6).PasteSpecial Paste:=xlPasteValues 

       Cells(21, 1).Copy 
       ws5.Cells(rw3, 7).PasteSpecial Paste:=xlPasteValues 


       Cells(17, 1).Copy 
       ws5.Cells(rw3, 8).PasteSpecial Paste:=xlPasteValues 
       Cells(17, 2).Copy 
       ws5.Cells(rw3, 9).PasteSpecial Paste:=xlPasteValues 
       Cells(17, 3).Copy 
       ws5.Cells(rw3, 10).PasteSpecial Paste:=xlPasteValues 

       Cells(3, 2).Copy 
       ws5.Cells(rw3, 11).PasteSpecial Paste:=xlPasteValues 
       Cells(4, 2).Copy 
       ws5.Cells(rw3, 12).PasteSpecial Paste:=xlPasteValues 

      End If 
     End If 

     If ws.Name Like "*" & "Sheetf" & "*" Then 
      ws.Select 
      If ws.Cells(5, 2).Value = "COMPLETE" Then 

       Cells(9, 1).Copy 
       ws6.Cells(rw4, 1).PasteSpecial Paste:=xlPasteValues 
       Cells(9, 2).Copy 
       ws6.Cells(rw4, 2).PasteSpecial Paste:=xlPasteValues 
       Cells(9, 3).Copy 
       ws6.Cells(rw4, 3).PasteSpecial Paste:=xlPasteValues 
       Cells(11, 1).Copy 
       ws6.Cells(rw4, 4).PasteSpecial Paste:=xlPasteValues 
       Cells(15, 2).Copy 
       ws6.Cells(rw4, 5).PasteSpecial Paste:=xlPasteValues 
       Cells(15, 3).Copy 
       ws6.Cells(rw4, 6).PasteSpecial Paste:=xlPasteValues 

       Cells(3, 2).Copy 
       ws5.Cells(rw3, 7).PasteSpecial Paste:=xlPasteValues 
       Cells(4, 2).Copy 
       ws5.Cells(rw3, 8).PasteSpecial Paste:=xlPasteValues 

      End If 
     End If 

    Next ws 

    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
End Sub 

Answer 1

關閉Application.Calculations，消除選擇並通過使用數組減少寫入次數會加速您的代碼。

Sub AppendRow(ws As Worksheet, ParamArray Args()) 
    With ws 
     With .Range("A" & .Rows.Count).End(xlUp).Offset(1) 
      .Resize(1, UBound(Args(), 1) + 1) = Args 
     End With 
    End With 
End Sub 

Sub ToggleEvents(EnableEvents As Boolean) 
    With Application 
     .DisplayAlerts = EnableEvents 
     .EnableEvents = EnableEvents 
     .ScreenUpdating = EnableEvents 
     .Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual) 
    End With 
End Sub 

---

Public Sub Validation() 
    ToggleEvents False 
    Dim ws As Worksheet 
    Dim wkb1 As Workbook: Set wkb1 = ThisWorkbook 
    Dim wkb2 As Workbook: Set wkb2 = Workbooks.Open("workbook2xlsx") 
    For Each ws In ActiveWorkbook.Worksheets 
     With ws 
      If .Cells(5, 2).Value = "COMPLETE" Then 
       If .Name Like "*sheeta*" Then 
        AppendRow wkb2.Worksheets("sheeta"), .Cells(9, 1), .Cells(29, 2), .Cells(29, 3), .Cells(15, 1), .Cells(39, 1), .Cells(39, 2), .Cells(39, 3), .Cells(55, 1), .Cells(55, 2), .Cells(55, 3), .Cells(55, 4), .Cells(57, 1), .Cells(57, 2), .Cells(57, 3), .Cells(57, 4), .Cells(59, 1), .Cells(59, 2), .Cells(59, 3), .Cells(59, 4), .Cells(61, 1), .Cells(61, 2), .Cells(3, 2), .Cells(4, 2) 
       ElseIf .Name Like "*sheetb*" Then 
        AppendRow wkb2.Worksheets("sheetb"), .Cells(9, 1), .Cells(9, 2), .Cells(26, 1), .Cells(14, 1), .Cells(26, 2), .Cells(26, 3), .Cells(30, 4), .Cells(32, 4), .Cells(46, 1), .Cells(46, 2), .Cells(46, 3), .Cells(46, 4), .Cells(48, 1), .Cells(48, 2), .Cells(48, 3), .Cells(48, 4), .Cells(50, 1), .Cells(50, 2), .Cells(50, 3), .Cells(50, 4), .Cells(52, 4), .Cells(3, 2), .Cells(4, 2) 
       ElseIf .Name Like "*sheetc*" Then 
        AppendRow wkb2.Worksheets("sheetc"), .Cells(9, 1), .Cells(9, 3), .Cells(9, 2), .Cells(23, 1), .Cells(19, 2), .Cells(19, 3), .Cells(13, 1), .Cells(13, 2), .Cells(33, 1), .Cells(33, 2), .Cells(33, 3), .Cells(33, 4), .Cells(35, 1), .Cells(35, 2), .Cells(35, 3), .Cells(35, 4), .Cells(37, 1), .Cells(37, 2), .Cells(37, 3), .Cells(37, 4), .Cells(39, 4), .Cells(3, 2), .Cells(4, 2) 
       ElseIf .Name Like "*sheetd*" Then 
        AppendRow wkb2.Worksheets("sheetd"), .Cells(9, 1), .Cells(9, 2), .Cells(9, 4), .Cells(13, 1), .Cells(13, 2), .Cells(13, 3), .Cells(21, 1), .Cells(17, 1), .Cells(17, 2), .Cells(17, 3), .Cells(3, 2), .Cells(4, 2) 
       ElseIf .Name Like "*sheetf*" Then 
        AppendRow wkb2.Worksheets("Sheetf"), .Cells(9, 1), .Cells(9, 2), .Cells(9, 3), .Cells(11, 1), .Cells(15, 2), .Cells(15, 3), .Cells(3, 2), .Cells(4, 2) 
       End If 
      End If 
     End With 
    Next 
    ToggleEvents True 
End Sub