Home » excel » excel – Is there a way to speed up this VBA code?

excel – Is there a way to speed up this VBA code?

Posted by: admin May 14, 2020 Leave a comment


This script is written to reach out to a directory and extract data from a number of .xlsm files and past it into a target file. The issue that I am having is that the code wants to open each one individually, pull the data, then close. This results in an extremely slow operation. Is there a method to speeding this up or changing the structure of my code to speed up the operation?

I have this working piece of code, but it is extremely slow.

Option Explicit

Const FOLDER_PATH = "C:\Users\maxd\OneDrive - Nortek, Inc\Coil Test Data\coils_35_and_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

This code results in a successful operation, but with 10 .xlsm files, it will take about 20 – 30 seconds to process them, if not longer.

How to&Answers:

Assuming cell A1 is populated in the Report sheet, you can use SQL to connect to the .xlsm workbooks and then extract the desired cells. Something like this should work for you, and will hopefully be faster as well:

Sub tgr()
'Requires Tools -> References "Microsoft AvctiveX Data Objects 2.1" (or higher; I used 6.1)

    Dim sqlConn As ADODB.Connection
    Dim sqlRS As ADODB.Recordset
    Dim rDest As Range
    Dim aResults() As Variant
    Dim sFolder As String
    Dim sFile As String
    Dim ixResult As Long
    Dim ixSQL As Long

    'Change to the correct workbook, sheet, and cell that results should start on
    Set rDest = ActiveWorkbook.Worksheets("Sheet1").Range("A11")

    sFolder = "C:\Users\maxd\OneDrive - Nortek, Inc\Coil Test Data\coils_35_and_36\WET\Testing\"  'REMEMBER END BACKSLASH
    sFile = Dir(sFolder & "*.xlsm")

    'Assumes a maximum of 65000 results
    '14 columns to populate A:N
    ReDim aResults(1 To 65000, 1 To 14)
        'These are the column numbers (1 = A, 2 = B, etc).  Change as needed if column order ever needs to be adjusted
        Const YearCol As Long = 1
        Const CFMCol As Long = 2
        'No result for column 3 (C) ?
        Const FaceVelCol As Long = 4
        Const AVGCapCol As Long = 5
        Const APDCol As Long = 6
        Const WPDCol As Long = 7
        Const InletDBCol As Long = 8
        Const InletWBCol As Long = 9
        'No result for column 10 (J) ?
        Const InletWTCol As Long = 11
        Const OutletWTCol As Long = 12
        Const HeatBalCol As Long = 13
        Const FileNameCol As Long = 14

    Do While Len(sFile) > 0
        Set sqlConn = New ADODB.Connection
        Set sqlRS = New ADODB.Recordset

        sqlConn.provider = "Microsoft.ACE.OLEDB.12.0"
        sqlConn.ConnectionString = "Data Source='" & sFolder & sFile & "';Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
        On Error Resume Next
        sqlRS.Open "SELECT *  FROM [Report$]", sqlConn, adOpenKeyset
        On Error GoTo 0

        If sqlRS.State <> 0 Then
            ixSQL = 0
            ixResult = ixResult + 1
            If Not sqlRS.BOF Then sqlRS.MoveFirst
            Do Until sqlRS.EOF = True
                ixSQL = ixSQL + 1
                Select Case ixSQL
                    Case 8:     aResults(ixResult, YearCol) = sqlRS(4).Value
                    Case 15:    aResults(ixResult, InletWTCol) = sqlRS(11).Value
                    Case 16:    aResults(ixResult, OutletWTCol) = sqlRS(11).Value
                    Case 21:    aResults(ixResult, InletDBCol) = sqlRS(3).Value
                                aResults(ixResult, HeatBalCol) = sqlRS(11).Value
                    Case 22:    aResults(ixResult, InletWBCol) = sqlRS(3).Value
                    Case 28:    aResults(ixResult, APDCol) = sqlRS(3).Value
                    Case 29:    aResults(ixResult, CFMCol) = sqlRS(3).Value
                    Case 33:    aResults(ixResult, WPDCol) = sqlRS(3).Value
                    Case 35:    aResults(ixResult, AVGCapCol) = sqlRS(3).Value
                End Select
                aResults(ixResult, FaceVelCol) = aResults(ixResult, CFMCol) / 6.25  '(30 * 30 / 144) = 6.25
                aResults(ixResult, FileNameCol) = sFile
        End If
        Set sqlRS = Nothing
        Set sqlConn = Nothing
        sFile = Dir

    If ixResult > 0 Then rDest.Resize(ixResult, UBound(aResults, 2)).Value = aResults

End Sub