Is there a way to speed this guy up? The code is designed to go into a directory, open up all of the .xlsm files in the folder, and copy specific data into a target file. This code works as is, but it is extremely slow. Is there a way to speed it up?

Const FOLDER_PATH = "C:\Users\maxd\OneDrive - Nortek, Inc\Coil Test Data\coils_35_and_36\36\WET\Testing\"  'REMEMBER END BACKSLASH

Sub ImportWorksheets()
   'Process all Excel files in specified folder
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long         'output row

   rowTarget = 11

   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If

   'reset application settings in event of error
   On Error GoTo errHandler
   Application.ScreenUpdating = False

   'set up the target worksheet
   Set wsTarget = Sheets("Sheet1")

   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xlsm*")
   Do Until sFile = ""

      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets("Report")

      'import the data
      With wsTarget
         .Range("A" & rowTarget).Value = wsSource.Range("E9").Value 'Year
         .Range("B" & rowTarget).Value = wsSource.Range("D30").Value 'CFM
         '.Range("D" & rowTarget).Value = wsSource.Range("D30/(30*30/144)").Value 'Face Velocity
         .Range("E" & rowTarget).Value = wsSource.Range("D36").Value 'AVG Capacity
         .Range("F" & rowTarget).Value = wsSource.Range("D29").Value 'APD
         .Range("G" & rowTarget).Value = wsSource.Range("D34").Value 'WPD
         .Range("H" & rowTarget).Value = wsSource.Range("D22").Value 'Inlet db
         .Range("I" & rowTarget).Value = wsSource.Range("D23").Value 'Inlet  wb
         '.Range("J" & rowTarget).Value = wsSource.Range("").Value 'Inlet dp
         .Range("K" & rowTarget).Value = wsSource.Range("L16").Value 'Inlet WT
         .Range("L" & rowTarget).Value = wsSource.Range("L17").Value 'Outlet WT
         .Range("M" & rowTarget).Value = wsSource.Range("L22").Value 'Heat Balance

         'optional source filename in the last column
         .Range("N" & rowTarget).Value = sFile
      End With

      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()

'Loop for face velocity
  Dim r As Integer
  Dim i As Integer

i = Cells(Rows.Count, 1).End(xlUp).Row
    For r = 11 To i
        Cells(r, 4) = "=RC[-2]/(30*30/144)"
    Next r

   On Error Resume Next
   Application.ScreenUpdating = True

   'tidy up
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing

End Sub

Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function


It's been a while since I wrote VBA, but I seem to remember Application.Calculation = xlCalculationManual often sped up my programs considerably. This prevents formulae from being evaluated while you're updating cell values, and can be reversed via Application.Calculation = xlCalculationAutomatic.


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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