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

Answer 1

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