求助修改Excel VBA代码 导出UTF-8 CSV存至桌面自定义文件夹

原代码核心问题 #

• 调用SaveAs方法时仅传入纯文件名，未指定完整绝对存储路径，导致Excel自动将导出文件存放至系统“我的文档”目录
• 缺少动态路径适配能力，无法识别用户手动调整的桌面存储位置，也不支持桌面下自定义子文件夹的自动创建
• 存在冗余无效的对象赋值逻辑，实际运行时可能错误导出非目标工作表的内容

调整后的完整可运行代码 #

Sub SaveWorkSheetAsCSV()
    Dim wbNew As Excel.Workbook
    Dim wsSource As Excel.Worksheet
    Dim fileName As String
    Dim desktopPath As String
    Dim customSaveFolder As String
    Dim fullSavePath As String
    
    ' 读取系统真实桌面路径，适配用户自定义调整的桌面位置
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    ' 自定义桌面下的目标存储文件夹名，可根据需求修改
    customSaveFolder = "ExcelCSV导出"
    ' 拼接完整存储目录路径
    fullSavePath = desktopPath & "\" & customSaveFolder
    ' 目标文件夹不存在时自动创建，避免保存报错
    If Dir(fullSavePath, vbDirectory) = "" Then
        MkDir fullSavePath
    End If
    
    ' 定义导出的CSV文件名
    fileName = "test.csv"
    
    Application.DisplayAlerts = False ' 关闭文件覆盖提示弹窗
    ' 定位要导出的目标工作表
    Set wsSource = ThisWorkbook.Worksheets(1)
    ' 复制目标工作表到新的临时工作簿
    wsSource.Copy
    Set wbNew = ActiveWorkbook
    ' 以完整路径保存为UTF8编码CSV文件
    wbNew.SaveAs Filename:=fullSavePath & "\" & fileName, FileFormat:=xlCSVUTF8
    ' 关闭临时工作簿，不保存多余改动
    wbNew.Close SaveChanges:=False
    Application.DisplayAlerts = True
End Sub

关键调整说明 #

• 动态路径获取：放弃硬编码盘符路径的写法，通过系统接口直接读取登记的真实桌面路径，即使用户将桌面迁移至非系统盘，也能准确定位目标目录
• 自定义目录适配：修改customSaveFolder 变量值即可自定义桌面下的存储文件夹，通过目录存在性判断自动补建缺失的文件夹，避免运行时报错
• 保存逻辑修正：将拼接完成的绝对路径传入SaveAs方法，彻底解决文件默认存入我的文档的问题，完全保留原代码的UTF8编码导出能力
• 导出逻辑优化：移除原代码中重复赋值的无效对象引用，通过工作表直接复制生成临时工作簿的方式导出，避免源文件被误修改，保证导出内容为指定的目标工作表

注意：xlCSVUTF8 格式常量仅在Excel 2016及以上版本内置，旧版本Excel运行时可将该常量替换为数值62，实现同等的UTF8编码导出效果。

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