Есть ли способ ускорить этот код VBA?

Question

Этот скрипт написан для обращения к каталогу и извлечения данных из ряда файлов .xlsm и вставки их в целевой файл.У меня проблема в том, что код хочет открыть каждый из них по отдельности, получить данные, а затем закрыть.Это приводит к крайне медленной работе.Есть ли способ ускорить это или изменить структуру моего кода для ускорения операции?

У меня есть этот рабочий фрагмент кода, но он очень медленный.

Option Explicit


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


'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



errHandler:
   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

Этот код приводит к успешной операции, но с 10 файлами .xlsm их обработка займет около 20-30 секунд, если не дольше.

Answer 1

Предполагая, что ячейка A1 заполнена на листе Report, вы можете использовать SQL для подключения к рабочим книгам .xlsm и затем извлечь нужные ячейки.Нечто подобное должно работать для вас, и, надеюсь, будет быстрее:

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\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"";"
        sqlConn.Open
        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
                sqlRS.MoveNext
            Loop
            sqlRS.Close
        End If
        sqlConn.Close
        Set sqlRS = Nothing
        Set sqlConn = Nothing
        sFile = Dir
    Loop

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

End Sub