从xlsm文件收集所有相关数据

Question

有办法让这家伙加速吗？代码用于进入目录，打开文件夹中的所有.xlsm文件，并将特定数据复制到目标文件中。这段代码工作正常，但速度非常慢。有办法加快速度吗？

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

Answer 1

我已经有一段时间没有写VBA了，但我似乎还记得Application.Calculation = xlCalculationManual经常会大大加快我的程序。这可以防止在更新单元格值时计算公式，并且可以通过Application.Calculation = xlCalculationAutomatic进行反转。