VBA多目录遍历异常：Dir函数调用冲突致主循环中断

你猜的没错！问题根源就是Dir函数的全局状态特性——整个VBA运行环境里只有一个Dir遍历指针。当你在fileLoation函数里调用Dir去遍历FINANCE文件时，它会直接覆盖掉主循环里Dir的当前遍历位置，等回到主循环执行myFile = Dir时，指针已经指向了FINANCE文件遍历的末尾，自然拿不到下一个CITIES文件了。

下面给你两种可靠的解决方案：

方案一：用FileSystemObject替代Dir（推荐） #

FileSystemObject是VBA里的面向对象文件操作工具，它没有Dir的全局状态问题，代码可读性和稳定性都更好。

修改后的完整代码如下：

Sub getTheExecSummary()
    Dim wb As Workbook
    Dim myPath As String
    Dim FSO As Object
    Dim folder As Object
    Dim file As Object
    Dim targetFiles As Collection
    Dim targetFile As Variant
    Dim prntStr As String
    Dim LookUpStr As String
    Dim replaceStr As String
    Dim financeFile As Object
    
    'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    myPath = "C:\Users\MORPHEUS\Documents\Projects\"
    
    '初始化FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(myPath)
    Set targetFiles = New Collection
    
    '第一步：收集所有包含CITIES的xls文件
    For Each file In folder.Files
        If LCase(file.Name) Like "*cities*.xls" Then
            targetFiles.Add file
        End If
    Next file
    
    '遍历收集到的CITIES文件
    For Each targetFile In targetFiles
        Set wb = Workbooks.Open(Filename:=targetFile.Path)
        
        prntStr = wb.Worksheets("Sheet1").Cells(1, 1) & " (n= " _
        & wb.Worksheets("Sheet2").Cells(12, 3) & ")"
        
        LookUpStr = wb.Name
        replaceStr = Left(LookUpStr, 10)
        LookUpStr = Replace(LookUpStr, replaceStr, "")
        
        '查找对应的FINANCE文件
        Set financeFile = FindFinanceFile(folder, LookUpStr)
        If Not financeFile Is Nothing Then
            Debug.Print financeFile.Name
        End If
        
        Workbooks("ExecutiveSummary.xlsm").Sheets("Sheet1").Range("A1").Value = targetFile.Name
        
        wb.Close SaveChanges:=False
    Next targetFile
    
    '恢复环境设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Function FindFinanceFile(folder As Object, LookUpStr As String) As Object
    Dim file As Object
    Set FindFinanceFile = Nothing
    
    For Each file In folder.Files
        '匹配包含FIN和LookUpStr的xls文件
        If LCase(file.Name) Like "*fin*.xls" And InStr(file.Name, LookUpStr) > 0 Then
            Set FindFinanceFile = file
            Exit For '找到第一个匹配的就退出
        End If
    Next file
End Function

方案二：用数组预存所有CITIES文件（兼容原Dir逻辑） #

如果你不想改太多代码，可以先把所有CITIES文件的路径一次性读进数组，然后遍历数组处理，这样子函数里的Dir调用就不会影响主循环了：

Sub getTheExecSummary()
    Dim wb As Workbook
    Dim myPath As String
    Dim myExtension As String
    Dim fileArr() As String
    Dim i As Integer
    Dim prntStr As String
    Dim LookUpStr As String
    Dim replaceStr As String
    Dim DoesTheFIleexist As String
    
    'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    myPath = "C:\Users\MORPHEUS\Documents\Projects\"
    myExtension = "*CITIES*.xls"
    
    '第一步：把所有CITIES文件读进数组
    i = 0
    myFile = Dir(myPath & myExtension)
    Do While Len(myFile) > 0
        i = i + 1
        ReDim Preserve fileArr(1 To i)
        fileArr(i) = myFile
        myFile = Dir
    Loop
    
    '遍历数组里的文件
    For i = 1 To UBound(fileArr)
        Set wb = Workbooks.Open(Filename:=myPath & fileArr(i))
        
        prntStr = wb.Worksheets("Sheet1").Cells(1, 1) & " (n= " _
        & wb.Worksheets("Sheet2").Cells(12, 3) & ")"
        
        LookUpStr = wb.Name
        replaceStr = Left(LookUpStr, 10)
        LookUpStr = Replace(LookUpStr, replaceStr, "")
        
        DoesTheFIleexist = fileLoation(myPath, LookUpStr)
        If Len(DoesTheFIleexist) > 0 Then
            Debug.Print DoesTheFIleexist
        End If
        
        Workbooks("ExecutiveSummary.xlsm").Sheets("Sheet1").Range("A1").Value = fileArr(i)
        
        wb.Close SaveChanges:=False
    Next i
    
    '恢复环境设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

'原fileLoation函数优化：找到匹配项就停止遍历，默认返回空
Function fileLoation(filePath As String, LookUpStr As String) As String
    Dim financeStr As String
    Dim myFile1 As String
    financeStr = "*FIN*.xls"
    myFile1 = Dir(filePath & financeStr)
    fileLoation = "" '默认返回空字符串
    
    Do While Len(myFile1) > 0
        Debug.Print ""
        Debug.Print myFile1
        If InStr(myFile1, LookUpStr) > 0 Then
            fileLoation = myFile1
            Exit Do '找到匹配的就退出循环，避免无效遍历
        End If
        myFile1 = Dir
    Loop
End Function

两种方案里，我更推荐方案一，因为FileSystemObject的API更强大，也彻底避免了Dir这类老函数的全局状态坑，后续维护起来更省心。

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