VBA宏首次运行报Error code 76，二次运行正常的修复咨询

我编写了一段用于在桌面创建文件夹并复制文件的VBA宏代码，首次运行时会触发Error code 76（路径未找到），但再次运行则完全正常。经排查，错误出现在代码行sfile = s5.Range("H1").Value & c.Offset(, -2).Value，当目标文件夹对应的单元格值变化时会触发该问题，请问该如何修复？

原代码 #

Sub lalalala ()

        Dim s5 As Worksheet
        Set s5 = ThisWorkbook.Sheets("Test")
    
        Dim DesktopPath As String
        Dim DesktopPathMAIN As String
        Dim DesktopPathSUB As String
        Dim file As String
        
        Dim sfile As String
        Dim sDFolder As String
        
        Dim oFSO As Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        
        
        DesktopPath = Environ("USERPROFILE") & "\Desktop\"
        DesktopPathMAIN = DesktopPath & "THE FINAL TEST"
        
        If Dir(DesktopPathMAIN, vbDirectory) = "" Then
            Shell ("cmd /c mkdir """ & DesktopPathMAIN & """")
        End If
        
        
        lastrow = s5.Range("B" & s5.Rows.Count).End(xlUp).Row
        Set rng = s5.Range("B1:B" & lastrow)
        
        For Each c In rng
            If Dir(DesktopPathMAIN & "\" & c.Offset(, 5).Value, vbDirectory) = "" Then
        Shell ("cmd /c mkdir """ & DesktopPathMAIN & "\" & c.Offset(, 5).Value & """")
            End If
        Next c
        
        
        lastrow = s5.Range("G" & s5.Rows.Count).End(xlUp).Row
        Set rng = s5.Range("G1:G" & lastrow)
        
        For Each c In rng
        
        sDFolder = DesktopPathMAIN & "\" & c.Value & "\"
        sfile = s5.Range("H1").Value & c.Offset(, -2).Value
        
        Call oFSO.CopyFile(sfile, sDFolder)
        
        Next c           
        
        End Sub

问题分析 #

Error 76的核心原因是复制时指定的源文件路径无效或不存在，首次运行触发、二次正常的具体诱因包括：

1. 使用Shell调用cmd创建文件夹后，系统文件系统缓存存在延迟，导致后续路径判断或操作时，文件夹还未真正完成创建
2. sfile的路径拼接逻辑有缺陷：如果H1单元格的路径末尾没有添加\，拼接后会变成C:\SourceFolderFile.txt这种错误格式
3. 混合使用Dir和FSO两种路径判断方式，逻辑不一致，且Shell没有返回创建成功的确认，后续操作无等待机制

修复方案 #

1. 统一使用FSO处理文件夹创建 #

替代Shell调用，FSO的CreateFolder更可靠，且会立即确认文件夹创建完成，避免缓存延迟问题。

2. 校验源文件路径有效性 #

复制前先判断源文件是否存在，避免触发路径错误。

3. 优化路径拼接逻辑 #

确保H1的路径末尾带有\，如果没有则自动补充，避免拼接错误。

4. 简化重复代码逻辑 #

减少重复的变量定义，让代码更清晰。

修复后的完整代码 #

Sub lalalala()
    Dim s5 As Worksheet
    Set s5 = ThisWorkbook.Sheets("Test")
    
    Dim DesktopPath As String
    Dim DesktopPathMAIN As String
    Dim sfile As String
    Dim sDFolder As String
    Dim oFSO As Object
    Dim lastrow As Long
    Dim rng As Range
    Dim c As Range
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    ' 获取桌面路径，确保末尾带\
    DesktopPath = Environ("USERPROFILE") & "\Desktop\"
    DesktopPathMAIN = DesktopPath & "THE FINAL TEST"
    
    ' 用FSO创建主文件夹（自动忽略已存在的情况）
    If Not oFSO.FolderExists(DesktopPathMAIN) Then
        oFSO.CreateFolder DesktopPathMAIN
    End If
    
    ' 创建子文件夹（从B列循环，对应G列的文件夹名）
    lastrow = s5.Range("B" & s5.Rows.Count).End(xlUp).Row
    Set rng = s5.Range("B1:B" & lastrow)
    For Each c In rng
        sDFolder = DesktopPathMAIN & "\" & c.Offset(, 5).Value
        If Not oFSO.FolderExists(sDFolder) Then
            oFSO.CreateFolder sDFolder
        End If
    Next c
    
    ' 复制文件（从G列循环）
    lastrow = s5.Range("G" & s5.Rows.Count).End(xlUp).Row
    Set rng = s5.Range("G1:G" & lastrow)
    For Each c In rng
        ' 处理H1的路径，确保末尾带\
        Dim sourceBasePath As String
        sourceBasePath = s5.Range("H1").Value
        If Right(sourceBasePath, 1) <> "\" Then
            sourceBasePath = sourceBasePath & "\"
        End If
        
        sfile = sourceBasePath & c.Offset(, -2).Value
        sDFolder = DesktopPathMAIN & "\" & c.Value & "\"
        
        ' 校验源文件存在后再复制
        If oFSO.FileExists(sfile) Then
            oFSO.CopyFile sfile, sDFolder, True ' True表示覆盖已存在文件
        Else
            MsgBox "源文件不存在：" & sfile, vbExclamation
        End If
    Next c
End Sub

关键修复点说明 #

• 用oFSO.FolderExists替代Dir判断文件夹，用oFSO.CreateFolder替代Shell，彻底解决系统缓存延迟问题
• 自动补充H1路径末尾的\，避免拼接出错误的源文件路径
• 增加oFSO.FileExists判断，提前拦截不存在的源文件，同时用提示框告知用户异常
• 显式声明所有变量（比如lastrow As Long），避免隐式类型转换问题

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