Excel vba更快地读取大量文件

Question

我编写了一个代码，它查找所有以特定名称开头的文件并从中读取数据，文件夹中通常有 1k 个文件或更多文件，我编写了一个小基准测试并意识到我的代码每秒读取大约 1 个文件，那就是很多时间。我对 VBA 很陌生，我想知道我是否采取了错误的方法？
功能代码:

Function ReadDataFromWorksheet()
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim i As Integer

i = 1

Set XL = CreateObject("Excel.Application")

Do While i < (ArraySize + 1)
    Set WBK = XL.Workbooks.Open("PATH TO FILE")
    Array(i).Data1 = WBK.ActiveSheet.Range("F6").Value
    WBK.Close SaveChanges:=False
    i = i + 1
Loop

Set XL = Nothing
End Function

对不起我的拼写错误!...提前感谢您的帮助!

Answer 1

以下是您应该如何使用 Dir :

Function ReadDataFromWorksheet() As Variant

With Application
    .EnableEvents = False 'stop executing this code until we are done
    .DisplayAlerts = False
    .ScreenUpdating = False
    '.Calculation = xlCalculationManual
End With

Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim FileName As String, _
    FolderPath As String, _
    Results()
ReDim Results(0)

On Error Resume Next
Set XL = GetObject(, "Excel.Application")
If Err.Number > 0 Then Set XL = CreateObject("Excel.Application")
On Error GoTo 0

FolderPath = "C:/test/"
FileName = Dir(FolderPath & "*.xlsx")

Do While FileName <> ""
    Set WBK = XL.Workbooks.Open(FolderPath & FileName)
    Results(UBound(Results)) = WBK.ActiveSheet.Range("F6").Value
    WBK.Close SaveChanges:=False
    ReDim Preserve Results(UBound(Results) + 1)
    FileName = Dir
Loop
ReDim Preserve Results(UBound(Results) - 1)

Set WBK = Nothing
Set XL = Nothing

With Application
    .EnableEvents = True
    .DisplayAlerts = True
    .ScreenUpdating = True
    '.Calculation = xlCalculationAutomatic
End With

ReadDataFromWorksheet = Results
End Function