VBA code that pulls information from 1000+ files in directory performance

Question

Below is the code I am using to run through files in a folder, pull information from the files, and record that information on a sheet. I am not the original author of the main portion of the code. The files the code is opening are fairly large and there are 1000+ of them. I also hard coded the cells the code is pulling information from.

Is there any way to make this code run more efficiently?

Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim PartInfoArr() As Long
Dim ArrCount As Integer
Dim PartNum As Integer
Dim i As Integer
Dim DocDate As String
Dim j, r As Integer
Dim SeenPart, SeenCount As Integer


'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
ArrCount = 0



'folder path for where to pull files from
  myPath = "C:\Users\.........."


'Target File Extension (must include wildcard "*")
  myExtension = "*.xlsm*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)


'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Ensure Workbook has opened before moving on to next line of code
      DoEvents

'Coppy all file information
Sheets("Tool GT Block").Select
Range("B11:C11").Select

'While there are part numbers record all info for each into arry
While ActiveCell.Offset(i, 0) <> ""
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 0) = ActiveCell.Offset(i, 0)
    DocDate = Range("D8")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 1) = DocDate
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 2) = Range("D11")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 3) = Range("I9")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 4) = Range("I10")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 5) = Range("I12")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 6) = Range("I13")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 8) = Range("I15")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 9) = Range("I16")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 10) = Range("I17")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 11) = Range("I18")
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 12) = Range("I21")
    'min packing processing overall
    Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2").Offset(k, 13) = Range("R10")




i = i + 1
k = k + 1
Wend

' reset  var for next file
i = 0



    'Save and Close Workbook
      wb.Close SaveChanges:=False

    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop



ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


'Message Box when tasks are completed
  MsgBox "Task Complete!"

End Sub

Answer 1

Preamble

The first step to optimizing this code is most likely not something you'll think helpful. It's generally accepted wisdom among the regular VBA reviewers here that writing code should follow a three step-process:

1. Make it work
2. Make it right
3. Make it fast

The problem with the code you presented is that it's really long and hard to understand (and accordingly optimize). Basically you're jumping the gun and try to run before you walked.

---

Constants

Constants are values that can be known at compile time and that do not change when the macro is run. You should extract such values into module-level constants like so:

Private Const myPath As String = "C:\Users\...."
Private Const myExtension As String = "*.xlsm"
' ... ?

Variable definitions

It's great that you're declaring your variables. I didn't see an Option Explicit though. It's generally cleaner and easier to require variable declarations to prevent bugs from misspellings and other quirks. Use any security that the language can give you.

In addition to that there's a small weirdness about VBA and As-Declarations:

Dim j, r As Integer
Dim SeenPart, SeenCount As Integer

This code actually will make the types of r and SeenCount Integer, but j and SeenPart will be declared and used as Variant, which can slow your program down.

To prevent this behaviour from ruining your day, I'd recommend declaring each variable on a separate line.

Last but not least: Integer is a 16-bit signed integer. Modern CPUs are highly optimized for arithmetics on 32-bit signed (and unsigned) integers. Surprisingly often it's faster in VBA to use Long over Integer.

Submethods

To make code easier to follow, it helps to keep the lifetime of variables and constructs as small as possible. This reduces the load on the reader's short-term memory and keeps capacity free to think about what the code actually means instead of just being preoccupied with which variables are actually relevant here.

Overall you should strive to make procedures as short as possible by extracting common code into a new procedure.

Consider:

Sub LoopAllExcelFilesInFolder()
    On Error GoTo ResetSettings
    OptimizeMacroSpeed()

    AggregateData()

ResetSettings: 
    ReinstituteApplicationState()
    On Error GoTo 0
End Sub

This is very easy to understand at the first reading. Of course it doesn't contain all information that you need, but it helps you understand the overall goal of the code. Now AggregateData could read something like this:

Sub AggregateData() 
    Dim myFile As String
    myFile = Dir(myPath & myExtension)

    Do While myFile <> ""
        Dim workbook As Workbook
        Set workbook = Workbooks.Open(Filename := myPath & myFile)
        ' Ensure workbook has opened
        DoEvents
        CopyData(workbook)

        workbook.Close SaveChanges := False
        ' Ensure workbook has closed
        DoEvents
        myFile = Dir
    Loop
End Sub

At this point it should be fairly obvious what CopyData should be doing, so I won't elaborate further :)

Finally Optimizations

First things first: Accessing a Worksheet is slow. Accessing a Workbook also is. What you accordingly want to do is minimize the number of times you do so.

Since VBA is an interpreted language (after having been compiled to p-code), every instruction is executed independently. This means that the copy-process is terrifyingly slow:

Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2")

^^ this code is executed every single line, which means a tremendous overhead.

Luckily VBA has a builtin mechanism to help us with this:

With Workbooks("MTM File.xlsm").Worksheets("MTM Pack Process Data").Range("A2")
    .Offset(k, 0) = ActiveCell.Offset(i, 0)
    .Offset(k, 1) = Range("D8")
    .Offset(k, 2) = Range("D11")
    ' ...
End With

Instead of executing the whole chain of Workbooks(..).Worksheets(..).Range("A2") every line, now VBA executes the chain only once and keeps a reference of that object in the with-block. This object can now be accessed directly and most of the overhead is removed.

A word of caution

The word of caution also is a possible optimization... Working with Selection and ActiveWorkbook and ActiveWorksheet is downright dangerous. In the middle of macro execution, your user could click on things, change the reference and suddenly data is not where you expect it anymore and everything breaks.

To prevent that you should always (read: whenever possible) keep a reference to a Range or Worksheet you're working with in a variable. That is pretty safe from the user and also allows for some minor optimizations.

Answer 2

k is undeclared.

Always use Option Explicit to ensure undeclared variables are caught at run-time. You can make sure Option Explicit is added to the top of every module by ticking the "Require Variable Declaration setting in Tools -> Options... An added bonus is that if you use CamelCase when declaring variables and lowercase when typing them in your code, you get instant visual feedback if you type an undeclared variable.

PartInfoArr(), ArrCount, PartNum, SeenPart, SeenCount, j and r are not used. I've deleted their declarations.

I've used constants as suggested by @vogel612.

DocDate = Range("D8") was only used once so I've deleted it.

Do Events passes control to the operating system. Control is returned after the operating system has finished processing the events in its queue and all keys in the SendKeys queue have been sent. In VBA commands are executed sequentially so Do Events is not required to "Ensure Workbook has opened before moving on to next line of code". That said, it is good practice to include it within loops to allow code execution to be interrupted by pressing Ctrl Break if you get into an unintended infinite loop.

Don't use Select. Set Sheet or Range variables instead and use With... End With constructs where appropriate. When using With... End With make sure you precede the object properties or methods with a period otherwise you may get unexpected results

Don't use ActiveCell - set a Range variable and use it.

While ActiveCell.Offset(i, 0) <> "" only makes sense if you have another Part No in B12 and beyond.

As the values being copied don't change for each iteration of i, reading them into an array before entering the loop to reduce the size of the loop.

I've declared CopyArray(1 to 13) as Variant but if your data allows, declare it as a specific type (e.g. Long, String, Double).

Note that Select is not used anywhere in the following code!

Option Explicit

Private Const myPath As String = "C:\Users\....\"
Private Const myExtension As String = "*.xls*"

Sub CopyFromExcelFilesInFolder()
Dim myFile As String
Dim SourceWB As Workbook
Dim SourceSht As Worksheet
Dim SourceRefCell As Range
Dim DestWB As Workbook
Dim DestSht As Worksheet
Dim DestRefCell As Range
Dim i As Long                       'Integer type is obsolete
Dim k As Long                       'declare k
Dim CopyArray(1 To 13) As Variant   'change to String, Long etc. as appropriate.

NeedForSpeed
On Error GoTo ResetSettings:
Set DestWB = ThisWorkbook
Set DestSht = DestWB.Sheets("MTM Pack Process Data")
Set DestRefCell = DestSht.Range("A2")

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

'explicitly initialize k.  Not absolutely necessary but for clarity
k = 0

'Loop through each Excel file in folder
Do While myFile <> ""
    If myFile <> ThisWorkbook.Name Then
        Set SourceWB = Workbooks.Open(Filename:=myPath & myFile)
        Set SourceSht = SourceWB.Sheets("Tool GT Block")
        Set SourceRefCell = SourceSht.Range("B11")
        'reset i
        i = 0

        With SourceSht
            CopyArray(1) = .Range("D8")
            CopyArray(2) = .Range("D11")
            CopyArray(3) = .Range("I9")
            CopyArray(4) = .Range("I10")
            CopyArray(5) = .Range("I12")
            CopyArray(6) = .Range("I13")
            CopyArray(7) = ""
            CopyArray(8) = .Range("I15")
            CopyArray(9) = .Range("I16")
            CopyArray(10) = .Range("I17")
            CopyArray(11) = .Range("I18")
            CopyArray(12) = .Range("I21")
            CopyArray(13) = .Range("R10")
        End With
        'Write to DestinationWB While there are part numbers in SourceWB
        While SourceRefCell.Offset(i, 0) <> ""
            With DestRefCell
                .Offset(k, 0) = SourceRefCell.Offset(i, 0)
                DestSht.Range(.Offset(k, 1), .Offset(k, 13)) = CopyArray
            End With
            i = i + 1
            k = k + 1
        Wend

        'Save and Close Workbook
        SourceWB.Close SaveChanges:=False
    End If

    'allow user to Ctrl + Break out of unexpected infinite loop
    DoEvents
    'Get next file name
    myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
    ResetSpeed
End Sub

Sub NeedForSpeed()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub

Sub ResetSpeed()
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

I haven't speed tested this against your code because I can't be bothered creating 1000+ workbooks. Please let me know if it is faster.