通过VBA将目录中缺失文件名补充至Excel列的异常问题求助

看起来你的宏遇到了两个核心问题：重复添加已存在的文件和单次运行仅添加一个文件。让我们一步步分析原因并给出修正方案：

原代码的核心问题 #

1. 键格式不匹配：你在字典中存储的是E列单元格的原始值（大概率是带扩展名的文件名），但判断时用的是GetBaseName(sFile)获取的不带扩展名的文件名。这就导致即使E列已有该文件，字典也会认为这个不带扩展名的名称不存在，从而重复添加。
2. 未处理E列初始为空的情况：如果E3及以上没有内容，Range("E" & Rows.Count).End(xlUp)可能定位到错误的行，导致添加异常。
3. 重复创建FileSystemObject：每次循环都新建一个FileSystemObject实例，既低效也可能引发潜在问题。

修正后的代码 #

根据你的需求（补充目录中的PDF文件到E列，不重复），我提供两种版本：

版本1：E列存储带扩展名的完整文件名 #

Sub GetFileNames()
    Dim sPath As String
    Dim sFile As String
    Dim lastRow As Long
    Dim existingFiles As Object ' Scripting.Dictionary
    Dim fso As Object ' Scripting.FileSystemObject
    
    ' 指定目标目录，确保路径以反斜杠结尾
    sPath = "C:\Directory\"
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    
    ' 初始化字典和文件系统对象
    Set existingFiles = CreateObject("Scripting.Dictionary")
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 加载E列已有的文件名（从E3开始）
    lastRow = Cells(Rows.Count, "E").End(xlUp).Row
    If lastRow >= 3 Then
        Dim cell As Range
        For Each cell In Range("E3:E" & lastRow)
            If cell.Value <> "" Then
                existingFiles.UCase(cell.Value) = Empty ' 不区分大小写判断
            End If
        Next cell
    End If
    
    ' 遍历目录中的PDF文件（如需所有文件改为"*.*"）
    sFile = Dir(sPath & "*.pdf", vbNormal) ' vbNormal仅处理文件，排除文件夹
    Do While sFile <> ""
        ' 检查文件是否已存在
        If Not existingFiles.Exists(UCase(sFile)) Then
            ' 找到E列最后一行，添加新文件
            lastRow = Cells(Rows.Count, "E").End(xlUp).Row
            If lastRow < 3 Then
                Cells(3, "E").Value = sFile
            Else
                Cells(lastRow + 1, "E").Value = sFile
            End If
            ' 将新文件加入字典，避免重复处理
            existingFiles.UCase(sFile) = Empty
        End If
        sFile = Dir ' 获取下一个文件
    Loop
    
    ' 释放内存
    Set existingFiles = Nothing
    Set fso = Nothing
    
    MsgBox "文件更新完成！", vbInformation
End Sub

版本2：E列存储不带扩展名的文件名 #

如果你需要在E列只显示文件名（不含.pdf），使用这个版本：

Sub GetFileNames_NoExtension()
    Dim sPath As String
    Dim sFile As String
    Dim lastRow As Long
    Dim existingFiles As Object ' Scripting.Dictionary
    Dim fso As Object ' Scripting.FileSystemObject
    Dim baseName As String
    
    ' 指定目标目录，确保路径以反斜杠结尾
    sPath = "C:\Directory\"
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    
    ' 初始化字典和文件系统对象
    Set existingFiles = CreateObject("Scripting.Dictionary")
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 加载E列已有的文件名（从E3开始）
    lastRow = Cells(Rows.Count, "E").End(xlUp).Row
    If lastRow >= 3 Then
        Dim cell As Range
        For Each cell In Range("E3:E" & lastRow)
            If cell.Value <> "" Then
                existingFiles.UCase(cell.Value) = Empty ' 不区分大小写判断
            End If
        Next cell
    End If
    
    ' 遍历目录中的PDF文件（如需所有文件改为"*.*"）
    sFile = Dir(sPath & "*.pdf", vbNormal) ' vbNormal仅处理文件，排除文件夹
    Do While sFile <> ""
        ' 获取不带扩展名的文件名
        baseName = fso.GetBaseName(sFile)
        ' 检查文件名是否已存在
        If Not existingFiles.Exists(UCase(baseName)) Then
            ' 找到E列最后一行，添加新文件
            lastRow = Cells(Rows.Count, "E").End(xlUp).Row
            If lastRow < 3 Then
                Cells(3, "E").Value = baseName
            Else
                Cells(lastRow + 1, "E").Value = baseName
            End If
            ' 将新文件名加入字典，避免重复处理
            existingFiles.UCase(baseName) = Empty
        End If
        sFile = Dir ' 获取下一个文件
    Loop
    
    ' 释放内存
    Set existingFiles = Nothing
    Set fso = Nothing
    
    MsgBox "文件更新完成！", vbInformation
End Sub

关键改进说明 #

• 统一键格式：确保字典存储的键和要添加的文件名格式完全一致（带/不带扩展名），彻底解决重复添加问题。
• 不区分大小写：通过UCase()统一转换为大写，避免因文件名大小写差异（如Document.pdf和document.pdf）导致的重复。
• 处理空列情况：当E3及以上没有内容时，直接从E3开始添加，避免定位错误。
• 高效对象管理：仅创建一次FileSystemObject和字典，提升代码运行效率。
• 精准文件筛选：使用vbNormal参数确保只处理文件（排除文件夹），并可通过*.pdf或*.*指定文件类型。

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