有没有办法加速这个 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