# Copying rows from one workbook to another

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
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

• What is IsWBOpen? Seems like a function. – Raystafarian Feb 3 '16 at 18:41
• 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? – Iron Man Feb 3 '16 at 18:44
• Just wondering. – Raystafarian Feb 3 '16 at 18:45
• 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. – Raystafarian Feb 4 '16 at 10:19

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
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.

• 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? – Iron Man Feb 3 '16 at 19:05
• My fault, I fixed it. – Raystafarian Feb 3 '16 at 19:14
• 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. – Iron Man Feb 3 '16 at 19:29
• No, you can't. VBA doesn't care about case. Where did I do that? – Raystafarian Feb 5 '16 at 16:43
• 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 – Raystafarian Feb 5 '16 at 16:44

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:

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.

• It makes complete sense, but I never thought of it as the business logic and presentation. That really helps. – Iron Man Feb 3 '16 at 21:16
• 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. – Kaz Feb 3 '16 at 21:41

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
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.

• 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 – Simon Forsberg Feb 12 '16 at 9:46
• @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. – Iron Man Feb 12 '16 at 15:56