Excel VBA按单元格值复制文件：规避文件夹已存在报错

原代码中使用MkDir创建文件夹时，若目标子文件夹已存在会触发「run-time error '58': File already exists」，核心问题是原有的文件夹存在判断逻辑不准确，且MkDir不支持覆盖已存在的文件夹。以下是两种可靠的解决方案：

方案1：改进Dir判断逻辑（无需额外对象） #

通过Dir函数结合vbDirectory参数，准确判断路径是否为已存在的文件夹，避免误判空文件夹或同名文件的情况：

将原代码中创建文件夹的代码段：

If Dir(sPath & "\" & ws.Range("H1")) = "" Then _
    MkDir sPath & "\" & ws.Range("H1")

替换为：

Dim targetFolder As String
targetFolder = sPath & "\" & ws.Range("H1")

' 先检查路径是否存在，再确认是否为文件夹
If Dir(targetFolder, vbDirectory) = "" Then
    MkDir targetFolder
Else
    ' 排除路径是同名文件的情况
    If (GetAttr(targetFolder) And vbDirectory) = 0 Then
        MkDir targetFolder
    End If
End If

方案2：使用FileSystemObject（更推荐） #

利用已引入的Scripting.FileSystemObject（FSO）来处理文件夹判断与创建，逻辑更清晰，兼容性更好：

修正后的完整代码 #

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")
    lastRow = ws.UsedRange.Rows.Count + ws.UsedRange.Row - 1
    sPath = "W:\Gegenpress Graphics\-- Crests Master\Clubs\Leagues"
    targetFolder = sPath & "\" & ws.Range("H1")

    ' 新增：检查H1是否为空，避免无效操作
    If ws.Range("H1").Value = "" Then Exit Sub
    
    ' 查找匹配的联赛记录
    Set rng = ws.Range("G1:G" & lastRow).Find(ws.Range("H1"), , xlValues, xlWhole, xlByColumns, xlNext)
    
    If Not rng Is Nothing Then
        firstFound = rng.Row
        
        ' 初始化FSO对象并处理文件夹创建
        Set fso = CreateObject("Scripting.FileSystemObject")
        If Not fso.FolderExists(targetFolder) Then
            fso.CreateFolder targetFolder
        End If
        
        ' 循环复制所有匹配的文件
        Do
            sFile = ws.Range("C" & rng.Row)
            sFile = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))
            fso.CopyFile Source:=ws.Range("C" & rng.Row), _
                         Destination:=targetFolder & "\" & sFile, _
                         OverWriteFiles:=False
                         
            Set rng = ws.Range("G1:G" & lastRow).FindNext(rng)
        Loop Until rng.Row = firstFound
    End If
    
    ' 释放资源
    Set fso = Nothing
    Set rng = Nothing
    Set ws = Nothing
End Sub

关键修改说明 #

1. 提前定义targetFolder变量：避免重复拼接路径，提升代码可读性与维护性
2. 新增H1非空判断：防止用户未输入联赛名称时执行无效操作
3. 用FSO的FolderExists判断文件夹：彻底解决原Dir函数的局限性，准确识别已存在的文件夹
4. 调整firstFound赋值位置：原代码中若未找到匹配联赛会触发对象未定义错误，现在移到If Not rng Is Nothing块内，避免报错
5. 增加对象释放语句：养成良好的VBA编码习惯，避免内存泄漏

额外提示 #

• 若需要覆盖目标文件夹内的同名文件，可将OverWriteFiles:=False改为OverWriteFiles:=True
• 若需处理更多异常（如源文件不存在），可添加fso.FileExists判断

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