如何通过VBA宏将MS Project项目标题设为文件名或合并时用文件名

方案一：打开项目时自动同步标题与文件名 #

通过VBA在合并前逐个打开项目，检查并将项目标题设置为文件名（不含扩展名），这样后续合并时子任务会自动使用文件名作为标题。

Sub SyncProjectTitleWithFilename()
    Dim proj As Project
    Dim fileName As String
    Dim projPath As String
    projPath = "C:\Your\Project\Directory\" ' 替换为你的实际目录路径
    Dim projFile As String
    projFile = Dir(projPath & "*.mpp")
    
    Do While projFile <> ""
        ' 打开目标项目
        Set proj = Projects.Open(projPath & projFile)
        
        ' 提取不含扩展名的文件名
        fileName = Left(projFile, InStrRev(projFile, ".") - 1)
        
        ' 对比标题与文件名，不一致则修改
        If proj.SummaryInfo.Title <> fileName Then
            proj.SummaryInfo.Title = fileName
            ' 如需自动保存修改，取消下面注释
            ' proj.Save
        End If
        
        ' 关闭项目（无需保留打开状态时执行）
        proj.Close
        
        ' 获取下一个项目文件
        projFile = Dir
    Loop
End Sub

执行完这个宏后，再运行你原有的合并代码，子任务标题就会和文件名保持一致。

方案二：合并后直接修改子任务名称为文件名 #

如果不想改动源项目的标题，可以在合并完成后，批量将子任务的名称替换为对应的文件名。

Sub ConsolidateWithFilenameAsTaskName()
    Dim projPath As String
    projPath = "C:\Your\Project\Directory\" ' 替换为你的实际目录路径
    Dim projFile As String
    projFile = Dir(projPath & "*.mpp")
    
    ' 执行原有的合并操作
    Do While projFile <> ""
        ConsolidateProjects Filenames:=projPath & projFile, NewWindow:=False, HideSubtasks:=True, AttachToSources:=False
        projFile = Dir
    Loop
    
    ' 遍历子项目，修改顶层任务名称为文件名
    Dim subProj As Subproject
    Dim fileName As String
    
    For Each subProj In ActiveProject.Subprojects
        ' 提取纯文件名（不含路径和扩展名）
        fileName = Mid(subProj.Path, InStrRev(subProj.Path, "\") + 1)
        fileName = Left(fileName, InStrRev(fileName, ".") - 1)
        
        ' 修改子项目对应的顶层任务名称
        subProj.SourceProject.Tasks(1).Name = fileName
    Next subProj
End Sub

注意：此代码默认子项目的顶层任务是第一个任务，若你的子项目结构特殊，需调整Tasks(1)的定位逻辑。

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