VBA按单元格指定路径创建Zip时无法复制文件夹问题求助

目标流程 #

• 在指定单元格区域内填写待打包的文件、文件夹完整路径
• 读取单元格路径内容，将对应文件、文件夹统一复制到临时目录
• 对临时目录内的所有内容生成Zip压缩包

示例输入 #

初始版本代码（仅支持文件复制） #

初始代码已实现单文件的读取复制，但无法处理文件夹路径：

Sub test()
    Dim rngFile As Range, cel As Range
    Dim desPath As String, filename As String

    Set rngFile = ThisWorkbook.Sheets("Instructions").Range("A3", "A5") 

    desPath = "C:\test\"

    For Each cel In rngFile
        If Dir(cel) <> "" Then
            filename = Dir(cel) 
            FileCopy cel, desPath & filename
        End If
    Next
End Sub

现存问题 #

当前代码仅能识别复制单个文件，无法对单元格中填写的文件夹路径执行复制操作，需要补充路径类型判断与文件夹复制逻辑，最终完成压缩包生成。

修正后完整代码（支持文件+文件夹混合复制+自动打包） #

核心调整点：

• 新增路径类型判断逻辑，自动区分单元格路径指向文件还是文件夹
• 调用FileSystemObject实现文件夹递归复制，自动包含目录下所有子文件、子层级
• 补充Windows原生Zip压缩逻辑，无第三方依赖
  注意：运行前请确保C盘有足够读写权限与存储空间，代码会自动创建不存在的临时目录

Sub GenerateZipFromCellPaths()
    Dim rngFile As Range, cel As Range
    Dim desTempPath As String, sourcePath As String, zipOutputPath As String
    Dim fso As Object
    
    ' 初始化配置
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set rngFile = ThisWorkbook.Sheets("Instructions").Range("A3", "A5")
    desTempPath = "C:\test\temp_pack\" ' 待压缩文件临时存放目录
    zipOutputPath = "C:\test\打包结果.zip" ' 最终压缩包输出路径
    
    ' 临时目录不存在则自动创建
    If Not fso.FolderExists(desTempPath) Then fso.CreateFolder desTempPath
    
    ' 遍历所有单元格路径
    For Each cel In rngFile
        sourcePath = Trim(cel.Value)
        ' 跳过空单元格
        If sourcePath = "" Then GoTo NextLoop
        ' 跳过不存在的路径
        If Not fso.PathExists(sourcePath) Then
            Debug.Print "无效路径，已跳过：" & sourcePath
            GoTo NextLoop
        End If
        
        ' 按路径类型分别执行复制
        If fso.FileExists(sourcePath) Then
            ' 复制单个文件
            fso.CopyFile sourcePath, fso.BuildPath(desTempPath, fso.GetFileName(sourcePath))
        ElseIf fso.FolderExists(sourcePath) Then
            ' 复制整个文件夹（含所有子内容）
            fso.CopyFolder sourcePath, fso.BuildPath(desTempPath, fso.GetFolder(sourcePath).Name) & "\"
        End If
NextLoop:
    Next cel
    
    ' 执行Zip压缩
    Call ZipFolder(desTempPath, zipOutputPath)
    
    ' 释放对象
    Set fso = Nothing
    MsgBox "压缩完成，文件保存路径：" & zipOutputPath, vbInformation
End Sub

' 系统原生Zip压缩函数，无需依赖第三方压缩软件
Sub ZipFolder(sourceFolder As String, zipPath As String)
    Dim shellObj As Object
    ' 写入Zip文件头初始化空压缩包
    Open zipPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    
    Set shellObj = CreateObject("Shell.Application")
    ' 将临时目录内容写入压缩包
    shellObj.Namespace(zipPath).CopyHere shellObj.Namespace(sourceFolder).Items
    
    ' 等待压缩完成，避免文件写入不完整
    On Error Resume Next
    Do Until shellObj.Namespace(zipPath).Items.Count = shellObj.Namespace(sourceFolder).Items.Count
        Application.Wait Now + TimeValue("0:00:01")
    Loop
    On Error GoTo 0
    
    Set shellObj = Nothing
End Sub

代码使用说明 #

• 可根据实际需求修改rngFile的单元格范围、临时目录路径、压缩包输出路径
• 文件夹复制默认保留原目录名，不会打乱原有文件结构
• 代码内置空值、无效路径跳过逻辑，不会因为个别路径错误中断整体运行

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