如何加速VBA遍历20000个文件夹文件的处理速度？

需求概述 #

需要用VBA实现以下优先级的文件搜索与处理：

• 优先查找今日修改的所有.txt文件
• 检查文件名是否与C3:C列的单元格内容部分匹配
• 在匹配的.txt文件中扫描与C3:C单元格值匹配的内容
• 执行指定的字符串替换等操作
• 处理完今日文件后，依次回溯处理昨日、前日的文件，最多回溯20天
• 所有目标文件找到或无文件可处理时停止

当前文件夹共有20000个文件，其中.txt文件占10%左右，现有代码处理总耗时超2分钟，单文件处理约0.007秒，需要进一步提速。

现有核心代码 #

' ======================= Sorting Algorithm ======================================
fileDate = 0
For fileDate = 0 To 20 'days back to search
    file = Dir(folderPath & "*.txt")
    For Each file In fs.getfolder(folderPath).files
    SRName = Replace(Left(Mid(file, 35), 6), "_", "") 'works if all names are 1234XY, trims underscores
        If file.datelastmodified >= Now - fileDate And LCase(Right(file.Name, 4)) = ".prl" Then  ' FILE MATCH
        ' =========== Part List Prep Array ============
            For Each cell In Range("C3:C" & LastRow) ' CELLS NAME MATCH TO CHECK IN FILE
            ToTestIndex = cell.Row - 2
            Homework = "PNL1," & cell
            If PartToTestArray(ToTestIndex) <> True And InStr(1, Homework, SRName, vbTextCompare) > 0 Then
                If InStr(1, Homework, SRName, vbTextCompare) > 0 Then
                    Cells(cell.Row, 6).Value = "Searching in " & "'" & Mid(file, 35, Len(file) - 38) & "'"
                    PartToTestArray(ToTestIndex) = True
                    Cells(cell.Row, 7).Value = file.datelastmodified
                End If
                End If
            Next cell
           ' =========== Part List Prep Array ============
            fileNumber = FreeFile ' Read the content of the file
            Open file For Input As fileNumber
            fileContent = Input$(LOF(fileNumber), fileNumber)
            Close fileNumber
            lines = Split(fileContent, vbCrLf) ' Split the content into an array of lines
           
            For i = 4 To UBound(lines) - 1 Step 3 ' new
                    For Each cell In Range("C3:C" & LastRow) ' Cells matching file testing
                    FoundIndex = cell.Row - 2
                    ToTestIndex = cell.Row - 2
                    If FoundPartArray(FoundIndex) <> True And PartToTestArray(ToTestIndex) = True Then
                    Homework = "PNL1," & cell
                    If lines(i) = "PNL4,0=" Then 'voodoo adjustment
                    i = i + 1
                    End If
                    If InStr(1, lines(i), Homework, vbTextCompare) > 0 Then ' Check if the line contains the Part Number
                        For QtySearch = 1 To 20 ' very small factor on the amount of total time for process
                            PartMultiplier = Cells(cell.Row, cell.Column + 2).Value
                            If InStr(1, lines(i), "0,0,0,0,0000,0", vbTextCompare) > 0 Then
                                PartMultiplier = PartMultiplier & ",0,0,0,0000,0"
                                ShotInTheDark = "0,0,0,0,0000,0"
                            Else
                                ShotInTheDark = "," & QtySearch & ",0,"
                                PartMultiplier = "," & PartMultiplier & ",0,"
                            End If
                            If InStr(1, lines(i), ShotInTheDark, vbTextCompare) > 0 Then
                                lines(i) = Replace(lines(i), ShotInTheDark, PartMultiplier)
                                Exit For ' Exiting QtySearch
                            End If
                        Next QtySearch
                        AddPart = lines(i) & vbCrLf & lines(i + 1) & vbCrLf & lines(i + 2) & vbCrLf ' Concatenate the current, previous, and next lines
                        FoundPartArray(FoundIndex) = True ' PART IS FOUND
                                Cells(cell.Row, 6).Value = Mid(file, 35, Len(file) - 38)
                                Cells(cell.Row, 7).Value = file.datelastmodified
                                cell.Interior.Color = RGB(0, 255, 0) ' green
                                outputContent = outputContent & AddPart
                        Exit For ' cell exit
                    End If
                    End If
                Next cell ' cell row increment
            Next i ' row in prl file increment
            file = Dir ' Get the next file in the folder
        End If
    Next file ' next file in folder increment
    AllPartsFound = True
  For FoundIndex = LBound(FoundPartArray) To UBound(FoundPartArray)
        If Not FoundPartArray(FoundIndex) Then
        AllPartsFound = False
Exit For
        End If
        Next FoundIndex
        If AllPartsFound = True Then
        fileDate = 20
        End If
Next fileDate
' ======================= Sorting Algorithm ======================================

已尝试的优化方法 #

• 合并/拆分修改日期+扩展名的判断语句，测试最优写法
• 对比「遍历一个文件匹配所有单元格」与「遍历一个单元格匹配所有文件」的效率，当前采用前者速度更快

优化建议 #

1. 提前将文件列表存入数组，减少磁盘IO #

现有代码每次循环都重新遍历文件夹，效率极低。可以一次性把所有符合条件的文件（.txt/修改日期在20天内）按日期分组存入数组，后续直接遍历数组：

' 示例：预处理文件列表到数组
Dim fileArr() As Variant
Dim idx As Integer
idx = 0
Set folder = fs.getfolder(folderPath)
For Each f In folder.files
    If LCase(Right(f.Name, 4)) = ".prl" And f.datelastmodified >= Now - 20 Then
        idx = idx + 1
        ReDim Preserve fileArr(1 To idx)
        Set fileArr(idx) = f
    End If
Next f
' 再按修改日期降序排序数组（今日在前，昨日在后）
Dim i As Integer, j As Integer
Dim temp As Object
For i = 1 To idx - 1
    For j = i + 1 To idx
        If fileArr(i).datelastmodified < fileArr(j).datelastmodified Then
            Set temp = fileArr(i)
            Set fileArr(i) = fileArr(j)
            Set fileArr(j) = temp
        End If
    Next j
Next i

这样只需遍历文件夹一次，后续操作都在内存中进行，大幅减少磁盘访问耗时。

2. 将单元格数据批量读入数组，避免反复读写工作表 #

现有代码多次直接读写Cells对象，这是VBA中耗时极高的操作。可以先把C3:C列、需要的其他列数据批量读入内存数组：

' 批量读取单元格数据到数组
Dim partArr() As Variant, multiplierArr() As Variant
Dim lastRow As Long
lastRow = Range("C" & Rows.Count).End(xlUp).Row
partArr = Range("C3:C" & lastRow).Value
multiplierArr = Range("E3:E" & lastRow).Value ' 对应cell.Column+2的列

后续所有判断、取值都直接使用数组，最后再把结果一次性写回工作表，能节省大量时间。

3. 前置文件筛选逻辑，减少无效处理 #

现在代码是先遍历所有文件，再判断日期和扩展名，建议先把不符合条件的文件直接排除，只保留20天内的.txt文件，减少循环次数。

4. 启用屏幕刷新关闭与事件禁用 #

在代码开头添加以下语句，避免工作表频繁刷新导致的耗时：

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

代码结束后恢复：

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

5. 采用Windows任务计划提前分类文件 #

你提到的用Task Scheduler每日同步2-3次，把.txt文件单独复制到子文件夹的方案非常有效，能直接把搜索范围缩小90%，建议优先采用。后续VBA只需处理子文件夹内的文件，效率会大幅提升。

6. 优化循环嵌套逻辑 #

现有代码中存在多层嵌套循环，且有重复判断（比如两次InStr(1, Homework, SRName, vbTextCompare) > 0），可以合并重复判断，减少不必要的计算；同时，一旦所有零件都找到（AllPartsFound=True），直接终止所有循环，避免无效遍历。

内容的提问来源于stack exchange，提问作者Alex Danishevsky