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

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.

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.

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.