如何优化遍历37000行数据的Excel宏以提升运行速度？

问题背景 #

我有一个Excel宏，需要遍历文件中的37000行数据，在按「年份文件夹-季度子文件夹」分类的同步SharePoint文件系统中匹配文件名，需满足以下要求：

• 找到匹配文件时，将文件信息添加至对应行；
• 未找到匹配文件时，在对应行填写"Not Found"；
• 若在任意文件夹（含同一文件夹）中发现重复文件，仅添加修改时间最新的文件信息。

当前该宏运行完成耗时超过13小时，我期望耗时能低于12小时，求提速的方法或重构方案。

原宏代码 #

Sub RecursiveLoop(folderPath As String, ws As Worksheet)
    Dim fs As Object
    Dim folder As Object
    Dim subfolder As Object
    Dim subsubfolder As Object
    Dim file As Object
    Dim subfolderPath As String
    Dim currentRow As Long
    Dim excelFileName As String
    Dim found As Boolean
    Dim recentFiles As New Dictionary ' Create a dictionary to store recent files
    

    spaddress = "/test/"

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set folder = fs.GetFolder(folderPath)

    For Each subfolder In folder.SubFolders ' Loop through year subfolders
        subfolderPath = subfolder.Path
        For Each subsubfolder In subfolder.SubFolders ' Loop through quarter subfolders
            found = False ' Reset the found flag for each quarter subfolder
            ' Clear the recentFiles dictionary for each sub-subfolder
            Set recentFiles = New Dictionary
            
            For i = 3 To ws.Cells(Rows.Count, "M").End(xlUp).Row
                excelFileName = ws.Cells(i, "M").Value
                For Each file In subsubfolder.Files
                    If InStr(1, file.Name, GetFileNameWithoutExtension(excelFileName), vbTextCompare) > 0 Then
                        ' Check if this is the most recent file for this excelFileName
                        If Not recentFiles.Exists(excelFileName) Then
                            ' If the file is not in the dictionary, add it
                            Set recentFiles(excelFileName) = file
                        ElseIf file.DateLastModified > recentFiles(excelFileName).DateLastModified Then
                            ' If the file is more recent, update the dictionary entry
                            Set recentFiles(excelFileName) = file
                        End If
                    End If
                Next file
                
                ' Process the most recent file for this excelFileName
                If recentFiles.Exists(excelFileName) Then
                    Set recentFile = recentFiles(excelFileName)
                    ws.Cells(i, "J").Value = "Approved by " & GetTrailingName(recentFile.Name, GetFileNameWithoutExtension(excelFileName))
                    pdfLink = Replace(excelFileName, " ", "%20")
                    If ws.Cells(i, "H") <> "" And ws.Cells(i, "E") = "" Then
                        ws.Hyperlinks.Add Anchor:=ws.Cells(i, "K"), Address:=spaddress & recentFile.Name, TextToDisplay:="link"
                    ElseIf ws.Cells(i, "E") <> "" And ws.Cells(i, "H") = "" Then
                        ws.Hyperlinks.Add Anchor:=ws.Cells(i, "L"), Address:=spaddress & recentFile.Name, TextToDisplay:="link"
                    ElseIf ws.Cells(i, "E") <> "" And ws.Cells(i, "H") <> "" Then
                        ws.Hyperlinks.Add Anchor:=ws.Cells(i, "K"), Address:=spaddress & recentFile.Name, TextToDisplay:="link"
                    End If
                End If
                
                found = True ' Mark as found if the file is found
            Next i
        Next subsubfolder
    Next subfolder

    Set fs = Nothing
    Set folder = Nothing
    Set subfolder = Nothing
    Set subsubfolder = Nothing
    Set file = Nothing
End Sub

核心优化方案 #

1. 重构循环逻辑：先扫文件，再匹配数据 #

原代码的嵌套循环逻辑是「年份→季度→Excel行→文件」，相当于每一行Excel数据都要遍历当前季度文件夹下的所有文件，37000行×N个文件的组合直接导致性能爆炸。

正确逻辑应该反过来：

• 第一步：遍历所有SharePoint文件夹，把所有文件按「匹配关键字（Excel M列的无后缀文件名）」整理到字典，只保留每个关键字对应的最新修改时间文件；
• 第二步：遍历Excel的37000行，直接从字典中查询匹配结果，批量写入Excel。

循环次数从「行数×文件数」降到「文件数+行数」，性能提升量级可达数倍到数十倍。

示例重构核心逻辑：

Sub OptimizedLoop(folderPath As String, ws As Worksheet)
    Dim fs As Object, folder As Object, subfolder As Object, subsubfolder As Object, file As Object
    Dim fileDict As New Dictionary, excelKeys As New Dictionary
    Dim key As String, lastRow As Long, i As Long
    Dim wsData As Variant
    
    spaddress = "/test/"
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set folder = fs.GetFolder(folderPath)
    
    ' 先读取Excel所有关键字到字典，避免重复处理
    lastRow = ws.Cells(Rows.Count, "M").End(xlUp).Row
    wsData = ws.Range("M3:M" & lastRow).Value
    For i = 1 To UBound(wsData)
        key = GetFileNameWithoutExtension(wsData(i, 1))
        If Not excelKeys.Exists(key) Then
            excelKeys.Add key, i + 2 ' 存储对应行号（从第3行开始）
        End If
    Next i
    
    ' 遍历所有文件，构建「关键字→最新文件」字典
    For Each subfolder In folder.SubFolders
        For Each subsubfolder In subfolder.SubFolders
            For Each file In subsubfolder.Files
                For Each key In excelKeys.Keys
                    If InStr(1, file.Name, key, vbTextCompare) > 0 Then
                        If Not fileDict.Exists(key) Then
                            Set fileDict(key) = file
                        ElseIf file.DateLastModified > fileDict(key).DateLastModified Then
                            Set fileDict(key) = file
                        End If
                    End If
                Next key
            Next file
        Next subsubfolder
    Next subfolder
    
    ' 批量写入Excel数据，关闭刷新和自动计算
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 初始化所有行的"Not Found"
    ws.Range("J3:J" & lastRow).Value = "Not Found"
    ws.Range("K3:L" & lastRow).ClearContents
    
    ' 匹配并写入结果
    For i = 3 To lastRow
        key = GetFileNameWithoutExtension(ws.Cells(i, "M").Value)
        If fileDict.Exists(key) Then
            Set recentFile = fileDict(key)
            ws.Cells(i, "J").Value = "Approved by " & GetTrailingName(recentFile.Name, key)
            
            ' 处理超链接
            If ws.Cells(i, "H") <> "" And ws.Cells(i, "E") = "" Then
                ws.Hyperlinks.Add Anchor:=ws.Cells(i, "K"), Address:=spaddress & recentFile.Name, TextToDisplay:="link"
            ElseIf ws.Cells(i, "E") <> "" And ws.Cells(i, "H") = "" Then
                ws.Hyperlinks.Add Anchor:=ws.Cells(i, "L"), Address:=spaddress & recentFile.Name, TextToDisplay:="link"
            Else
                ws.Hyperlinks.Add Anchor:=ws.Cells(i, "K"), Address:=spaddress & recentFile.Name, TextToDisplay:="link"
            End If
        End If
    Next i
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 释放对象
    Set fs = Nothing
    Set fileDict = Nothing
    Set excelKeys = Nothing
End Sub

2. 关闭Excel自动刷新与计算 #

原代码循环中频繁写入单元格、添加超链接，会触发Excel的屏幕刷新和自动计算，极大拖慢速度。操作Excel前添加：

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False ' 可选，关闭事件触发

操作完成后恢复：

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

3. 用数组批量读写Excel数据 #

原代码每次循环直接读取单个单元格值，效率极低。建议先把整列数据批量读取到数组，处理后再批量写入：

' 批量读取
lastRow = ws.Cells(Rows.Count, "M").End(xlUp).Row
wsData = ws.Range("M3:M" & lastRow).Value

' 批量写入示例
ws.Range("J3:J" & lastRow).Value = resultArray

4. 优化字典使用逻辑 #

原代码每个季度文件夹都重新创建recentFiles字典，导致重复处理。应全局维护一个字典，存储所有文件夹中每个关键字的最新文件，避免重复判断。

5. 缓存自定义函数结果 #

原代码中GetFileNameWithoutExtension和GetTrailingName在循环中被多次调用，建议将结果缓存到变量中，减少函数调用开销：

key = GetFileNameWithoutExtension(excelFileName)
' 后续直接使用key变量，避免重复调用函数

6. 优化SharePoint文件访问 #

如果是同步到本地的SharePoint文件夹：

• 确保本地同步完成后再运行宏；
• 避免在遍历文件时调用DateLastModified以外的属性，减少IO操作；
• 可考虑用PowerShell预扫描文件并生成CSV，再让Excel读取CSV匹配，PowerShell的文件遍历速度远快于VBA。

额外建议 #

• 先测试小批量数据（如1000行）验证优化逻辑正确性，再跑全量数据；
• 若文件数量极大，可借助第三方库或调用外部脚本实现多线程处理；
• 检查GetFileNameWithoutExtension和GetTrailingName函数的内部逻辑，确保无低效操作。

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