Copying rows from one workbook to another

Question

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

• Raystafarian: What is IsWBOpen? Seems like a function.
• Iron Man: It is a function, but it only checks to see if the workbook for the current month is open. If it is not, the sub ends. Would it be helpful if I edit my question and post that code?
• Raystafarian: Just wondering.
• Raystafarian: I think you should put the checkmark next to zak's answer. I may have been first, but I think his answer is a better one.

Answer 1

First and foremost - use Option Explcit and give your variables meaningful names.

ANS --> msgBoxValue
LR - Just use lastRow, it's not in use yet.
LastRow
i --> You can use i, but I never do. Why not tell us what it's doing?
erow --> currentRow

Now I see you removing data that isn't from January. You could clean that up a bit, but there's nothing explicitly wrong with what you're doing.

Moving to your noted loop, that can be cleaned up. You're using copy and paste which is slow compared to just using the actual data -

Dim sourceWorkBook As Workbook
Dim destinationWorkbook As Workbook
Dim LastRow As Integer, sourceRow As Integer, destinationRow As Integer
destinationRow = destinationWorkbook.Cells(Rows.Count, 1).End(xlUp) + 1
LastRow = sourceWorkBook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For sourceRow = 2 To LastRow
 If Cells(sourceRow, 2) = "1" Then
 destinationWorkbook.Sheets("Swivel").Rows(destinationRow) = sourceWorkBook.ActiveSheet.Rows(sourceRow)
 destinationRow = destinationRow + 1
 End If
Next sourceRow

Or better yet -

Dim sourceWorkBook As Workbook
set sourceWorkbook = thisworkbook
Dim destinationWorkbook As Workbook
set destinationWorkbook = workbooks("Swivel - Master - January 2016")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkBook.Sheets("Extract")
Dim destinationWorksheet As Worksheet
Set destinationWorksheet = destinationWorkbook.Sheets("Swivel")
Dim lastRow As Integer
lastRow = sourceWorksheet.Range("A" & Rows.Count).End(xlUp).Row
Dim sourceRow As Integer
Dim destinationRow As Integer
destinationRow = destinationWorkbook.Cells(Rows.Count, 1).End(xlUp) + 1
For sourceRow = 2 To lastRow
 If Cells(sourceRow, 2) = "1" Then
 destinationWorksheet.Rows(destinationRow) = sourceWorksheet.Rows(sourceRow)
 destinationRow = destinationRow + 1
 End If
Next sourceRow

I'd also get those ranges out of the sort key fields with variables -

 Dim firstKey As Range
 Set firstKey = sourceWorksheet.Range("B2:B2000")
 Dim secondKey As Range
 Set secondKey = sourceWorksheet.Range("D2:D2000")
 Dim thirdKey As Range
 Set thirdKey = sourceWorksheet.Range("O2:O2000")
 Dim fourthKey As Range
 Set fourthKey = sourceWorksheet.Range("J2:J2000")
 Dim fifthKey As Range
 Set fifthKey = sourceWorksheet.Range("K2:K2000")
 Dim sixthKey As Range
 Set sixthKey = sourceWorksheet.Range("L2:L2000")
 With sourceWorksheet.Sort
 With .SortFields
 .Clear
 .Add Key:=firstKey, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 .Add Key:=secondKey, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 .Add Key:=thirdKey, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 .Add Key:=fourthKey, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 .Add Key:=fifthKey, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 .Add Key:=sixthKey, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 End With
 .SetRange Range("A2:AE2000")
 .Apply
 End With

You might also want to make comments that explain why something is happening instead of what is happening -

' This line autofits the columns C, D, O, and P
' This unhides any hidden rows

This code is self-explanatory, no need for comments.

However, a comment would be helpful for

'Calls IsWBOpen to ensure the data is available
 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")

and

'What's happening here?
 Application.Run "'Swivel - Master - January 2016.xlsm'!Unfilter"

Speaking of ANS, by defining the workbooks up front, you will be able to handle an error if the data isn't available. You could also force it open. You could get rid of the entire user prompt. As long as DisplayAlerts is working

Dim destinationWorkbook As Workbook
Set destinationWorkbook = Workbooks.Open("Swivel - Master - January 2016.xlsm")

Will throw an alert if anything is wrong. Then just handle that and the user won't need to check. Or handle it silently.

• Iron Man: This is probably going to be a stupid question, but how does the code you provided determine that the destination workbook is "Swivel - Master - January 2016.xlsm"? Do I need to 'Set' those?
• Raystafarian: My fault, I fixed it.
• Iron Man: Thanks. So, here is something interesting, I added the Option Explicit at the top of the module, then I realized I needed to clarify the destination workbook part. In the meantime, I ran our hourly extract (which uses this code), and it did the copy/paste in a blink. So is it possible that just adding Option Explicit could make that much difference? I am still going to test and use your code above as it is much cleaner and better defined (appreciate that a lot btw), but am curious about this discovery.
• Raystafarian: No, you can't. VBA doesn't care about case. Where did I do that?
• Raystafarian: I did say if you have a variable declared and not in use, you can use it before you first intended if it won't be needed then

Answer 2

The 3 lowest hanging fruit in the VBA performance garden are

• Application.ScreenUpdating = False

• Application.EnableEvents = False

• Application.Calculation = xlCalculationManual

Personally, I have the following standard Methods for dealing with those:

Public varScreenUpdating As Boolean
Public varEnableEvents As Boolean
Public varCalculation As XlCalculation
Public Sub StoreApplicationSettings()
 varScreenUpdating = Application.ScreenUpdating
 varEnableEvents = Application.EnableEvents
 varCalculation = Application.Calculation
End Sub
Public Sub DisableApplicationSettings()
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual
End Sub
Public Sub RestoreApplicationSettings()
 Application.ScreenUpdating = varScreenUpdating
 Application.EnableEvents = varEnableEvents
 Application.Calculation = varCalculation
End Sub

Which will return the settings to whatever they were before your sub runs. But, if you really want to do it properly, this question is a much better implementation.

---

Now, onto the golden rule of spreadsheet manipulations:
Separate your business logic from your presentation.

Your presentation is your spreadsheet, it's where the end user sees and interacts with the data. Your business logic is the stuff your macros do to that data.

Doing stuff in spreadsheets has a huge computational overhead. Everytime you reference a range or do something to a cell or copy/paste, there's all sorts of computations that go on behind the scenes. Ever tried deleting a row in a spreadsheet with lots of data in it? It can take whole seconds by itself.

This leads us to the most important suggestion (and the one that, by itself, will *vastly* speed up your procedure).

Put your data in an Array.

---

Dim dataRange as Range
Set dataRange = Range(Cells(firstRow, firstCol), Cells(lastRow, lastCol))
Dim dataArray as Variant
dataArray = Array()
dataArray = dataRange

That's all you need, and now, rather than having data in Cells(x, y), you have data in dataArray(x, y)

Now, say you want to only keep the data from january?

Dim monthCol as Long
monthCol = '/ whatever column it is
Dim filteredArray as Variant
filteredArray = Array()
Dim ix As Long, iy As Long
Dim matchCounter as Long
Dim LB1 as Long, UB1 as long
Dim LB2 as long, UB2 as long
LB1 = LBound(dataArray, 1)
UB1 = UBound(dataArray, 1)
LB2 = LBound(dataArray, 2)
UB2 = UBound(dataArray, 2)
ReDIm filteredArray (LB2 to UB2, 1 to 1) '/ Reverse Row/Columns because you can only extend the last dimension of an Array whilst preserving data
dim monthIndex as Long
matchCounter = 0
for ix = LB1 to Ub1
 monthIndex = dataArray(ix, monthCol)
 If monthIndex = 1 then
 matchCounter = matchCounter + 1
 redim preserve(filteredArray(Lb2 to UB2, 1 to matchCounter)
 for iy = LB2 to UB2
 filteredArray(iy, matchCounter) = dataArray(ix, iy)
 next iy
 End If
Next ix
Dim printCell as Range, printRange as Range
Set printCell = printSheet.Cells(1,1)
Set printRange = printSheet.Range(printCell, Cells(printcell.row + matchCounter - 1, printCell.Column + (UB2 - Lb2))
'/ Transpose the filtered Array because it's still arranged in (column, row) then:
printRange = filteredArray 

No messing around with deleting rows. No huge performance costs from interacting with the worksheet. Just interact with it once at the start, to get the data, and once at the end, to print the data, and everything in the middle will run 10-100x faster.

• Iron Man: It makes complete sense, but I never thought of it as the business logic and presentation. That really helps.
• Kaz: As a general rule: Where possibe, either do everything in the spreadsheet using functions, or do everything in VBA using computer-native constructs. Excel is highly optimised for both, but not for all the selecting, copy/pasting, deleting inserting etc. that people tend to do.

Answer 3

After some tweaking, and utilizing the knowledge gained from Fadi, Zak, and Raystafarian, here is the final code that worked for my purposes. It reduced the amount of time to run from just over three minutes to 2 seconds. The area that increased the run time significantly was by changing the copy/paste that I was using.

The original code was running everything a row by row basis. As the file grew over the month, so did the amount of time to run the procedure. By creating a cleaner set of declarations, changing the As Integer to As Long throughout the code (which is another "low hanging fruit") the functionality as well as the performance of the code was greatly improved.

Thanks for all that assisted in getting it to this stage.

Sub Extract_Sort_1601_January()
'
 Dim ANS As Long
 Dim LR As Long
 Dim uRng As Range
 Dim she As Worksheet
 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
 Dim sourceWorkBook As Workbook
 Set sourceWorkBook = Workbooks("TEMPIMPORT.xlsx")
 Dim destinationWorkbook As Workbook
 Set destinationWorkbook = Workbooks("Swivel - Master - January 2016.xlsm")
 Dim sourceWorksheet As Worksheet
 Set sourceWorksheet = sourceWorkBook.Sheets("Extract")
 Dim destinationWorksheet As Worksheet
 Set destinationWorksheet = destinationWorkbook.Sheets("Swivel")
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual
 sourceWorksheet.Range("C:C,D:D,O:O,P:P").Columns.AutoFit
 sourceWorksheet.Cells.EntireRow.Hidden = False
 For LR = sourceWorksheet.Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
 If sourceWorksheet.Range("B" & LR).Value <> "1" Then
 If uRng Is Nothing Then
 Set uRng = sourceWorksheet.Rows(LR)
 Else
 Set uRng = Union(uRng, sourceWorksheet.Rows(LR))
 End If
 End If
 Next LR
 If Not uRng Is Nothing Then uRng.Delete
 For Each she In destinationWorkbook.Worksheets
 If she.FilterMode Then she.ShowAllData
 Next
 With sourceWorksheet.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
 sourceWorksheet.Cells.WrapText = False
 Dim lastRow As Long
 lastRow = sourceWorksheet.Range("A" & Rows.Count).End(xlUp).Row
 Dim destinationRow As Long
 destinationRow = destinationWorksheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
 sourceWorksheet.Range("A2:AA" & lastRow).Copy destinationWorksheet.Range("A" & destinationRow)
 Call ExtractSave
 Call DeleteTEMPIMPORTWorkbook
 Application.Run "'Swivel - Master - January 2016.xlsm'!Remove_Duplicates"
 Application.ScreenUpdating = True
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
End Sub

Since the sorting process was not a contributor to the amount of time this code ran, I kept it as is. I hope others find this useful.

• Simon Forsberg: At the moment this is not a good quality answer because it seems like a "code-only" answer. Either improve your answer to explain how you changed the code, or take a look at what to do after receiving answers
• Iron Man: @SimonForsberg Sorry Simon. I do not have enough knowledge to understand all of the improvement suggestions provided. I can say that I do not just take suggestions, improve the code and move on. I do take the time to understand why and how it worked. I read through a lot of posts daily. I wanted to share the final code here and figured that since the original was already posted, a reviewer can look through both sets and read the answers and comments. But, I understand your point and agree that I should have summed it up myself. I also gave proper credit to the contributors.