VBA代码滞后 – 我如何加快？

任何帮助将不胜感激

我有下面的代码，通过工作簿上的工作簿查看某个名称（例如，SheetA，Sheetb等）。 表格匹配后，如果某个关键字与选定表单匹配，它将开始从工作簿1的工作表中复制值并将其粘贴到工作簿2中。

我希望工作簿1中的数据在工作簿2中的现有数据下写入，而不是覆盖，这就是它正在做的事情。 不过，我现在的代码是一个一个的复制/粘贴。

我被告知我可以加快它，如果我将值保存到variables，并将其写入单元格，但我不知道如何去做

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

closuresApplication.Calculations，通过使用数组来消除select并减less写入次数将加速您的代码。

 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