编写此脚本是为了访问目录并从多个.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秒，甚至更长。
答案 0 :(得分：2)
假设Report工作表中已填充单元格A1，则可以使用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