Why is my VBA code going so slow? Too many loops?

Question

I am just learning to write in VBA and have written a code that allows a user to select a bunch of files to import into a master excel workbook with multiple sheets. The code matches the source data to the master data based on the tab names and appends the correct data to the correct tab. It also adds columns for date and location identifiers which are not a part of the original data file to each tab.

I think my code is working well but it just takes FOREVER to run. The point was to be able to speed this process up since it was done manually before but I think it may still take the same amount of time, but just waiting now. Sigh.

Here is my code -- any help is appreciated!

Option Explicit

Sub CopyData()
Dim erow As Long, lastrow As Long, lastcolumn As Long, WbMonthly As Workbook
Dim TargetFiles As FileDialog
Dim FileIdx As Long, DataBook As Workbook
Dim sheet As Worksheet, counter As Long
Dim coutner As Long
Dim index As Long, index2 As Long, i As Long, j As Long
Dim lastrowend As Long, lastrowmid As Long
Dim ws As Worksheet
Dim month As String
Dim year As Long
Dim day As Long


Set WbMonthly = ThisWorkbook
'Worksheets("Instructions").Active
month = Range("B5").Value
day = Range("D5").Value
year = Range("F5").Value

If IsEmpty(Sheets(1).Range("B5")) Then
    MsgBox ("Please enter a month before continuing")
    Exit Sub
End If

If IsEmpty(Sheets(1).Range("D5")) Then
    MsgBox ("Please enter a day before continuing")
    Exit Sub
End If

If IsEmpty(Sheets(1).Range("F5")) Then
    MsgBox ("Please enter a year before continuing")
    Exit Sub
End If

'Unhide datasheets
For Each ws In ActiveWorkbook.Worksheets
    ws.Visible = xlSheetVisible
Next ws


'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add ".xlsx files", "*.xlsx"
    .Show
End With



For FileIdx = 1 To TargetFiles.SelectedItems.Count
    'open the file and assign the workbook/worksheet
    Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
    Dim Filename As String
    Filename = DataBook.Name


    'if it is not the first data file, copy in the data by appending to what is already in the sheet
    For i = 1 To DataBook.Sheets.Count
    For j = 1 To WbMonthly.Sheets.Count

    If DataBook.Worksheets(i).Name = WbMonthly.Worksheets(j).Name Then

        'WbMonthly.Worksheets(counter + 2).Activate
        erow = WbMonthly.Sheets(j).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        DataBook.Sheets(i).Activate
        lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        Range(Cells(2, 1), Cells(lastrow, lastcolumn)).Copy _
        WbMonthly.Sheets(j).Cells(erow, 1)

        WbMonthly.Sheets(j).Activate
        lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        lastrowmid = ActiveSheet.Cells(Rows.Count, lastcolumn).End(xlUp).Row
        lastrowend = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            For index2 = lastrowmid + 1 To lastrowend
            ActiveSheet.Cells(index2, lastcolumn - 2) = left(Filename, 6)
            ActiveSheet.Cells(index2, lastcolumn - 1) = day & " " & month
            ActiveSheet.Cells(index2, lastcolumn) = year
            Next index2
    End If

    Next j
    Next i


Next FileIdx


'Close all of the datafiles
For FileIdx = 1 To TargetFiles.SelectedItems.Count
    Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
    DataBook.Close
Next FileIdx

'Hide datasheets
For i = 3 To WbMonthly.Sheets.Count
    Sheets(i).Select
    ActiveSheet.Visible = xlSheetHidden
Next i

WbMonthly.Sheets("INSTRUCTIONS").Activate
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " APP DATA files")
End Sub

[SO: Benchmarking VBA code](https://stackoverflow.com/questions/7103552/benchmarking-vba-code). — user202729, Mar 18 '18 at 14:01
Benchmarking is a good Idea. My guess is that activating the worksheets will slow down the process. Instead of activating the worksheets and use `Activesheet`, you can use the sheet directly in the code: `lastrow = Databook.Sheets(i).Cells(1, Columns.count).end(xlToLeft).Column` — Alex de Jong, Mar 18 '18 at 14:05
optimizing code is more likely to be a candidate for code review than SO. You can try avoiding Activate and set ranges = to each other between workbooks, put things in variables, potentially load data into arrays and work with the arrays rather than looping through the sheet. Avoid msgbox where possible (if you have to, better not to, use debug.print over msgbox - is this for you or user?) — QHarr, Mar 18 '18 at 14:09
Close files as soon as you have finished with them and set the workbook variable to nothing to conserve resources rather than closing at end (if that is an option). And see if you can do it with powerquery instead. — QHarr, Mar 18 '18 at 14:09
Hi! Thanks for your response! I tried benchmarking it (new to this so didn't know that was a thing until now as well!). I used the link from @user202729 and the "Tick" method so hopefully I did it correctly. The code was able to combine 7 files (each with 6 sheets of data) into the master file in 1028.093 — Julia Weidner, Mar 18 '18 at 14:27
You could try using `ADODB` and connect directly to the excel document. Then do an insert to update the sheet you want. — Ryan Wildry, Mar 18 '18 at 14:34
As far as I see you have not turned off automatic recalculation so whole excel is recalculating on each loop. Please reffer here: http://www.cpearson.com/excel/optimize.htm for some optimization tips. Most crucial are `Application.Calculation = xlCalculationManual` and `Application.ScreenUpdating = FALSE`. — TomJohn, Mar 18 '18 at 16:03
Further to @TomJohnRiddle suggestion you could also try turning off screen updating with `Application.ScreenUpdating = False`. Also remove the Active references from your code and use references to the sheet would help. Also, one more suggestion looping through a workbook is faster with a `For Each` loop so try looping through the workbooks with `For Each ws in Databook.sheets` and similar for the other loop. — Tom, Mar 18 '18 at 16:19

score 2 · Accepted Answer · answered Mar 18 '18 at 18:34

other then following all pieces of advice you got from the comments (mainly the turning off of automatic recalculation and screen updating at the beginning of your code and then turning them back on at the end), your code also suffers from:

unnecessary loops

you're looping through each opened workbook worksheet for every WbMonthly sheet, and this
Activate/Active coding pattern

all that sheet/workbook switching impact on performance and, more important, is prone to quickly loos control over what workbook/worksheet is actually active.

so use fully qualified workbook/worksheet range references
leaving all user selected files open until you close them all by the end

which involves memory usage and possibly additional computational effort (should all those opened workbooks recalculate at every copy/paste operation)

so you may consider the following refactoring of your code:

Sub CopyData()
    Dim TargetFiles As FileDialog
    Dim WbMonthly As Workbook
    Dim ws As Worksheet
    Dim lastrow As Long, lastcolumn As Long, lastrowend As Long, lastrowmid As Long
    Dim FileIdx As Long
    Dim i As Long
    Dim month As String
    Dim year As Long
    Dim day As Long


    Set WbMonthly = ThisWorkbook

    With WbMonthly.Sheets("Instructions")
        If IsEmpty(.Range("B5")) Then
            MsgBox ("Please enter a month before continuing")
            Exit Sub
        Else
            month = .Range("B5").Value
        End If

        If IsEmpty(.Range("D5")) Then
            MsgBox ("Please enter a day before continuing")
            Exit Sub
        Else
            day = .Range("D5").Value
        End If

        If IsEmpty(.Range("F5")) Then
            MsgBox ("Please enter a year before continuing")
            Exit Sub
        Else
            year = Range("F5").Value
        End If
    End With


    'Unhide datasheets
    For Each ws In ActiveWorkbook.Worksheets
        ws.Visible = xlSheetVisible
    Next ws

    'prompt user to select files
    Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
    With TargetFiles
        .AllowMultiSelect = True
        .Title = "Multi-select target data files:"
        .ButtonName = ""
        .Filters.Clear
        .Filters.Add ".xlsx files", "*.xlsx"
        .Show
    End With



    Dim Filename As String
    Dim DBsht As Worksheet, MNSht As Worksheet
    For FileIdx = 1 To TargetFiles.SelectedItems.Count

        With Workbooks.Open(TargetFiles.SelectedItems(FileIdx)) 'open the file and reference it as a workbook
            Filename = .Name

            For Each DBsht In .Worksheets 'loop through each newly opened file worksheets

                If GetSheet(WbMonthly, DBsht.Name, MNSht) Then ' if current sheet name matches one of 'WbMonthly' ones
                    With DBsht 'reference  newly opened file current sheet
                        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
                        lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
                        .Range(.Cells(2, 1), .Cells(lastrow, lastcolumn)).Copy _
                            MNSht.Cells(MNSht.Rows.Count, 1).End(xlUp).Offset(1, 0)
                    End With

                    With MNSht 'reference 'WbMonthly' sheet named after current newly opened file sheet
                        lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
                        lastrowmid = .Cells(.Rows.Count, lastcolumn).End(xlUp).Row
                        lastrowend = .Cells(.Rows.Count, 1).End(xlUp).Row
                        If lastrowmid < lastrowend Then .Cells(lastrowmid + 1, lastcolumn - 2).Resize(lastrowend - lastrowmid, 3).Value = Array(Left(Filename, 6), day & " " & month, year)
                    End With
                End If
            Next

            .Close False
        End With
    Next FileIdx


    'Hide datasheets
    With WbMonthly
        For i = 3 To .Sheets.Count
            .Sheets(i).Visible = xlSheetHidden
        Next i
        .Sheets("Instructions").Activate
    End With

    MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " APP DATA files")
End Sub


Function GetSheet(wb As Workbook, shtName As String, sht As Worksheet) As Boolean
    Set sht = Nothing
    On Error Resume Next
    Set sht = wb.Worksheets(shtName)
    GetSheet = Not sht Is Nothing
End Function

And where in your code auto-calculations are turned off? ;-) — TomJohn, Mar 18 '18 at 18:39
At the beginning I said _"Other than ..."_, meaning _"do that and then follow my pieces of advice, too"_ ...:-) — DisplayName, Mar 18 '18 at 18:41
This worked SUPERBLY! Thank you! I will definitely take the time to understand the nuances here and help my general coding! Thanks so much! — Julia Weidner, Mar 19 '18 at 01:00
@JuliaWeidner, you are welcome. You may then consider marking the answer as accepted. Thank you — DisplayName, Mar 19 '18 at 05:43

Why is my VBA code going so slow? Too many loops?

1 Answers1