Daruki
Reputation: 491
VBA Code lags - How can i quicken it?
Any help would be appreciated on this
I have the following code which looks through worksheets on workbook 1 with a certain name(E.g, SheetA, Sheetb, etc). After the sheet matches, if a certain critieria matches on the select sheet, it will start copying values from the sheet from workbook 1 and paste them into workbook 2.
I want the data from workbook 1 to write under existing data in workbook 2, not overwrite, which is what it's doing. however, my code right now is doing the copy/paste one by one.
I'm told I can quicken it if I save the values into variables and write them into cells, however I'm not sure how to go about it
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
Upvotes: 2
Views: 116
Answers (1)
user6432984
Reputation:
Turning off Application.Calculations, eliminating selections and reducing the number of writes by using arrays will speed up your code.
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
Upvotes: 3
Related Questions
- How can I speed up Excel VBA?
- How to prevent VBA code from slowing down?
- Assistance with slow VBA
- VBA Speeding up Code
- VBA code causing excel lagging
- Speed up the VBA code
- How do I speed up my code execution?
- Speeding up VBA code
- Excel 2010 VBA - How to optimize this code so it doesn't lag out?
- VBA code running horrendously slow