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

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, 2016 at 18:44
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, 2016 at 10:19

Community · Accepted Answer · 2017-05-23 12:41:03Z

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.

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, 2016 at 19:05
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, 2016 at 19:29
No, you can't. VBA doesn't care about case. Where did I do that? — Raystafarian, Feb 5, 2016 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, 2016 at 16:44

Community · Accepted Answer · 2017-04-13 12:40:52Z

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.

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

2 revs · Accepted Answer · 2016-02-12 15:47:35Z

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.

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, 2016 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, 2016 at 15:56

Stack Exchange Network

Copying rows from one workbook to another

3 Answers 3

Your Answer

Not the answer you're looking for? Browse other questions tagged
performance
vba
excel
or ask your own question.

Linked

Hot Network Questions

Copying rows from one workbook to another

3 Answers 3

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged performancevbaexcel or ask your own question.

Linked

Related

Hot Network Questions

Not the answer you're looking for? Browse other questions tagged
performance
vba
excel
or ask your own question.