This code will copy data from a workbook and copy it to an existing (and open) workbook. At the beginning of the month this copy/paste works very quickly, but as the month goes on and the data also grows, this process slows down to a couple of minutes. Once we start hitting 200 rows of data, we see the performance slow down. We run this on an hourly basis and there can be anywhere from 0 to 40 records added. For January, we reached over 900 rows of data and it took 3 minutes to run this code.
How can I make this run faster no matter how many rows need to be copied and pasted between workbooks?
Sub Extract_Sort_1601_January()
Dim ANS As Long
ANS = MsgBox("Is the January 2016 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
If ANS = vbNo Or IsWBOpen("Swivel - Master - January 2016") = False Then
MsgBox "The required workbook is not currently open. This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
Exit Sub
End If
Application.ScreenUpdating = False
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
' This removes any data that is not from January
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Range("B" & LR).Value <> "1" Then
Rows(LR).EntireRow.Delete
End If
Next LR
Application.Run "'Swivel - Master - January 2016.xlsm'!Unfilter"
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("D2:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("O2:O2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("J2:J2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("K2:K2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("L2:L2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:AE2000")
.Apply
End With
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = "1" Then
' As opposed to selecting the cells, this will copy them directly
Range(Cells(i, 1), Cells(i, 31)).Copy
' As opposed to "Activating" the workbook, and selecting the sheet, this will paste the cells directly
With Workbooks("Swivel - Master - January 2016.xlsm").Sheets("Swivel")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(erow, 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
End If
Next i
Application.ScreenUpdating = True
End Sub
I am sure that it is this last part where the performance is impacted as it is a For
/Next
loop. I do not know enough to change this to improve the performance and not loop through one row at a time.
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = "1" Then
' As opposed to selecting the cells, this will copy them directly
Range(Cells(i, 1), Cells(i, 31)).Copy
' As opposed to "Activating" the workbook, and selecting the sheet, this will paste the cells directly
With Workbooks("Swivel - Master - January 2016.xlsm").Sheets("Swivel")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(erow, 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
End If
Next i
Application.ScreenUpdating = True
End Sub
IsWBOpen
? Seems like a function. \$\endgroup\$