提取文件路径作业编号 生成自定义命名CSV的VBA实现

核心逻辑匹配规则 #

• 从当前XLSM工作簿的完整存储路径中，按反斜杠\拆分路径段
• 取拆分后第5个路径段（即示例中标注的项目目录段，数组计数从0开始时对应索引4的元素）
• 从该路径段中提取第一个短横线-前的内容作为作业编号
• 作业编号后拼接固定后缀import-TMP-AD-IFI-REV12，生成最终目标CSV文件名
• CSV文件存储位置与当前XLSM工作簿保持同目录，匹配示例的文件存档层级

优化后的可运行代码 #

替换原有代码中CSVfile变量的旧赋值逻辑，完整可运行代码如下：

Sub OverwriteData_In_CSV()
    Dim CSVfile As String
    
    ' 重写命名逻辑：替换原从DataFeed表N1单元格取值的旧规则
    ' 1. 拆分当前工作簿路径为独立路径段
    Dim pathSegments As Variant
    pathSegments = Split(ThisWorkbook.FullName, "\")
    
    ' 2. 提取第五层路径段（项目目录）
    Dim projectFolderName As String
    projectFolderName = pathSegments(4)
    
    ' 3. 提取段内的作业编号（第一个短横线前的内容）
    Dim jobNo As String
    jobNo = Split(projectFolderName, "-")(0)
    
    ' 4. 获取当前工作簿所在的保存目录
    Dim currentSaveDir As String
    currentSaveDir = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, "\"))
    
    ' 5. 拼接生成最终CSV完整存储路径
    CSVfile = currentSaveDir & jobNo & "import-TMP-AD-IFI-REV12.CSV"

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Foundation Budget Template")

    Application.ScreenUpdating = False
    ws.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=CSVfile, FileFormat:=xlCSV, Local:=True
    Application.DisplayAlerts = True
    ActiveWorkbook.Close SaveChanges:=False
    Application.ScreenUpdating = True
End Sub

适配调整说明 #

• 若后续项目路径的层级发生变动，仅需修改pathSegments的数组索引值，匹配实际的项目目录段位置即可
• 若作业编号的提取规则发生变化，仅需调整提取编号时的分割逻辑，适配新的目录命名格式
• 代码运行时会自动跳过保存时的格式提示弹窗，副本保存完成后自动关闭新建的临时CSV工作簿，不会改动原XLSM文件的内容

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