如何实现MS Project宏根据选中任务数量选择执行范围并复用代码

核心思路 #

• 将重复逻辑提取为独立子过程，通过参数传递任务集合（Tasks对象）实现代码复用，避免冗余
• 先识别用户选中任务数量，给出默认处理范围，再通过对话框让用户确认或手动选择执行范围
• 修复原宏中重复添加同名任务到集合的问题

完整优化代码 #

Sub task_names_fully_auto_de_dup()
    Dim targetTasks As Tasks
    Dim selectedCount As Integer
    Dim userChoice As Integer
    
    ' 获取选中任务数量
    selectedCount = ActiveSelection.Tasks.Count
    
    ' 弹出范围选择对话框
    userChoice = MsgBox("选择执行范围：" & vbCrLf & _
                        "1 = 仅处理选中任务（当前选中" & selectedCount & "个）" & vbCrLf & _
                        "2 = 处理整个项目", vbQuestion + vbYesNoCancel, "选择处理范围")
    
    ' 根据用户选择确定目标任务集合
    Select Case userChoice
        Case vbYes ' 处理选中任务
            If selectedCount < 1 Then
                MsgBox "未选中任何任务，将自动处理整个项目"
                Set targetTasks = ActiveProject.Tasks
            Else
                Set targetTasks = ActiveSelection.Tasks
            End If
        Case vbNo ' 处理整个项目
            Set targetTasks = ActiveProject.Tasks
        Case vbCancel ' 用户取消操作
            Exit Sub
    End Select
    
    ' 查找重复任务名称
    Dim Dups As New Collection
    Call FindDuplicateTaskNames(targetTasks, Dups)
    
    If Dups.Count = 0 Then
        MsgBox "未找到重复任务名称"
        Exit Sub
    End If
    
    ' 获取用户关于前缀/后缀和分隔符的选择
    Dim choice As Integer
    Dim Pre As String
    choice = InputBox("选择汇总名称添加位置：" & vbCrLf & "1 = 前缀" & vbCrLf & "2 = 后缀", "自动去重设置 1/2", 2)
    
    If choice = 1 Then ' 前缀模式
        Pre = InputBox("选择分隔符：" & vbCrLf & "1 = 空格" & vbCrLf & "2 = 短横线" & vbCrLf & "3 = 冒号", "分隔符选择 2/2", 2)
        Select Case Pre
            Case 1: Pre = " "
            Case 2: Pre = " - "
            Case 3: Pre = ": "
        End Select
    Else ' 后缀模式
        Pre = InputBox("选择分隔符：" & vbCrLf & "1 = 空格" & vbCrLf & "2 = 短横线" & vbCrLf & "3 = 括号", "分隔符选择 2/2", 3)
        Select Case Pre
            Case 1: Pre = " "
            Case 2: Pre = " - "
            Case 3: Pre = " ("
        End Select
    End If
    
    ' 处理重复任务名称
    Call ProcessDuplicateTaskNames(targetTasks, Dups, choice, Pre)
    
    MsgBox "任务名称去重完成"
End Sub

' 通用子过程：查找指定任务集合中的重复名称
Sub FindDuplicateTaskNames(sourceTasks As Tasks, ByRef dupsCollection As Collection)
    Dim t As Task
    Dim t_test As Task
    Dim isDuplicate As Boolean
    
    For Each t In sourceTasks
        If task_test(t) Then
            ' 检查当前名称是否已在重复集合中，避免重复添加
            isDuplicate = False
            On Error Resume Next
                isDuplicate = Not (dupsCollection(t.Name) Is Nothing)
            On Error GoTo 0
            
            If Not isDuplicate Then
                ' 在集合内查找同名不同ID的任务
                For Each t_test In sourceTasks
                    If task_test(t_test) Then
                        If t_test.Name = t.Name And t_test.ID <> t.ID Then
                            dupsCollection.Add t.Name, Key:=t.Name ' 用Key确保集合内名称唯一
                            Exit For ' 找到重复就停止当前任务的检查
                        End If
                    End If
                Next t_test
            End If
        End If
    Next t
End Sub

' 通用子过程：处理指定任务集合中的重复名称
Sub ProcessDuplicateTaskNames(sourceTasks As Tasks, dupsCollection As Collection, positionChoice As Integer, separator As String)
    Dim t As Task
    Dim SummaryName As String
    Dim WBS_String() As String
    Dim Target_WBS As String
    Dim t_wbs As Task
    Dim item As Variant
    
    For Each t In sourceTasks
        If task_test(t) Then
            For Each item In dupsCollection
                If t.Name = item Then
                    If InStr(1, t.WBS, ".") <> 0 Then ' 非顶级任务，获取父级名称
                        WBS_String = Split(t.WBS, ".")
                        ReDim Preserve WBS_String(LBound(WBS_String) To UBound(WBS_String) - 1)
                        Target_WBS = Join(WBS_String, ".")
                        
                        ' 父级任务可能不在选中范围内，因此遍历整个项目查找
                        For Each t_wbs In ActiveProject.Tasks
                            If task_test(t_wbs) Then
                                If t_wbs.WBS = Target_WBS Then
                                    SummaryName = t_wbs.Name
                                    Exit For
                                End If
                            End If
                        Next t_wbs
                        
                        ' 根据用户选择修改任务名称
                        If positionChoice = 1 Then
                            t.Name = SummaryName & separator & t.Name
                        Else
                            If separator = " (" Then
                                t.Name = t.Name & separator & SummaryName & ")"
                            Else
                                t.Name = t.Name & separator & SummaryName
                            End If
                        End If
                    End If
                End If
            Next item
        End If
    Next t
End Sub

Function task_test(t As Task) ' 验证任务是否有效（非空、非外部任务）
    task_test = True
    If t Is Nothing Then
        task_test = False
    ElseIf t.ExternalTask = True Then
        task_test = False
    End If
End Function

关键优化点说明 #

1. 代码复用设计

   • 将原宏中查找重复、处理重复的逻辑拆分为FindDuplicateTaskNames和ProcessDuplicateTaskNames两个通用子过程，通过sourceTasks参数接收不同范围的任务集合（项目全部任务或选中任务），彻底避免代码复制。

2. 智能范围选择

   • 自动识别选中任务数量，弹窗提供对应选项：选中多个任务时默认推荐处理选中范围，选中1个或未选中时自动切换为处理整个项目，同时支持用户手动选择范围或取消操作。

3. 集合去重修复

   • 原宏会重复添加同名任务到集合，优化后通过Key:=t.Name参数利用集合的键唯一性避免重复，同时增加前置检查减少无效遍历。

4. 逻辑正确性保障

   • 处理重复任务时，父级任务可能不在选中范围内，因此依然遍历整个项目查找父级WBS，确保名称修改逻辑的正确性。

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