任何幫助將不勝感激VBA代碼滯後 - 我如何加快它?
我有以下代碼,通過工作簿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
我剛剛發佈了一個答案。其中我認爲最後兩次複製操作是錯別字。 – 2016-10-02 04:35:21