基于单元格值批量复制文件的VBA代码报错修复请求

问题根源 #

原代码通过Dir()函数判断目标文件夹是否存在，但Dir()无法识别隐藏文件夹，且当文件夹实际存在时，执行MkDir会直接抛出Run-time error '58': File already exists错误。另外原代码未处理Find找不到匹配联赛的场景，会导致firstFound = rng.Row触发空对象错误。

修改后的完整代码 #

Sub Copy_Files()
    Dim rng As Range
    Dim firstFound As Long
    Dim lastRow As Long
    Dim sPath As String
    Dim sFile As String
    Dim ws As Worksheet
    Dim fso As Object
    Dim targetFolder As String
    
    ' 指定工作表
    Set ws = ThisWorkbook.Worksheets("Clubs")
    ' 获取G列最后一行数据行号（比UsedRange更可靠）
    lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    ' 根路径
    sPath = "W:\Gegenpress Graphics\-- Crests Master\Clubs\Leagues"
    ' 目标子文件夹完整路径
    targetFolder = sPath & "\" & ws.Range("H1").Value
    
    ' 提前创建FileSystemObject对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 检查H1是否为空
    If ws.Range("H1").Value = "" Then
        MsgBox "请在H1单元格输入联赛名称！", vbExclamation
        Exit Sub
    End If
    
    ' 查找匹配的联赛记录
    Set rng = ws.Range("G1:G" & lastRow).Find(ws.Range("H1"), , xlValues, xlWhole, xlByColumns, xlNext)
    
    ' 找到匹配记录才执行后续操作
    If Not rng Is Nothing Then
        firstFound = rng.Row
        ' 用FileSystemObject判断文件夹是否存在，不存在则创建
        If Not fso.FolderExists(targetFolder) Then
            fso.CreateFolder targetFolder
        End If
        
        Do
            ' 获取源文件路径并执行复制
            sFile = ws.Range("C" & rng.Row).Value
            fso.CopyFile Source:=sFile, Destination:=targetFolder & "\", OverWriteFiles:=False
            
            ' 查找下一条匹配记录
            Set rng = ws.Range("G1:G" & lastRow).FindNext(rng)
            ' 防止找不到下一条时进入死循环
            If rng Is Nothing Then Exit Do
        Loop Until rng.Row = firstFound
    Else
        MsgBox "未找到匹配的联赛记录！", vbInformation
    End If
    
    ' 释放对象，避免内存占用
    Set fso = Nothing
    Set ws = Nothing
    Set rng = Nothing
End Sub

关键改动说明 #

1. 替换文件夹存在判断逻辑：用FileSystemObject.FolderExists()替代Dir()，该方法能准确识别包括隐藏文件夹在内的所有合法文件夹，彻底避免误判。
2. 统一用FileSystemObject处理文件操作：提前创建fso对象，同时用它完成文件夹创建和文件复制，逻辑更一致，减少冗余代码。
3. 增加边界检查：H1为空时直接提示退出，避免无效操作；找不到匹配联赛时给出明确提示，防止代码崩溃。
4. 优化行号获取方式：用Cells(Rows.Count, "G").End(xlUp).Row替代UsedRange，避免因表格空行导致的行号错误。
5. 简化文件复制逻辑：无需手动截取文件名，fso会自动将源文件复制到目标文件夹下，保持原文件名。

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