请求编写MS Project VBA代码：按多字符串分组任务并支持视图切换

问题说明 #

• MS Project原生分组仅支持按单元格完整字符串分组，无法处理单元格内逗号分隔的多个值，导致单个任务无法归属多个分组。
• 需要实现支持多分组的视图，且能像原生功能一样随时取消分组并恢复原视图。
• 已完成分组名称与对应任务列表的收集，但缺少临时分组摘要任务的创建与视图切换逻辑，无法形成独立的分组视图。

完整VBA代码 #

Sub GroupTasksByString()
    Dim selectedColumn As String
    Dim task As Task
    Dim splitValues() As String
    Dim i As Integer
    Dim uniqueGroups As Object
    Dim cellValue As String
    Dim groupName As String
    Dim key As Variant
    Dim newSummary As Task
    Dim newTask As Task
    
    ' 检查是否已处于分组状态
    Dim isGrouped As Boolean
    isGrouped = False
    For Each task In ActiveProject.Tasks
        If Not task Is Nothing And task.GetField(FieldNameToFieldConstant("Flag1")) = True Then
            isGrouped = True
            Exit For
        End If
    Next task
    
    If isGrouped Then
        ' 恢复原视图
        UngroupByString
        Exit Sub
    End If
    
    ' 提示用户输入分组列名
    selectedColumn = InputBox("Enter the name of the column to group by (e.g., Text1, Text2, etc.):", "Group By Column")
    If selectedColumn = "" Then
        MsgBox "No column name entered. Macro will exit.", vbExclamation
        Exit Sub
    End If
    
    ' 创建字典存储分组与对应任务
    Set uniqueGroups = CreateObject("Scripting.Dictionary")
    
    ' 遍历所有任务，收集分组信息
    For Each task In ActiveProject.Tasks
        If Not task Is Nothing And Not task.Summary Then
            cellValue = task.GetField(FieldNameToFieldConstant(selectedColumn))
            If cellValue <> "" Then
                splitValues = Split(cellValue, ",")
                For i = LBound(splitValues) To UBound(splitValues)
                    groupName = Trim(splitValues(i))
                    If groupName <> "" Then
                        If Not uniqueGroups.Exists(groupName) Then
                            uniqueGroups.Add groupName, New Collection
                        End If
                        uniqueGroups(groupName).Add task
                    End If
                Next i
            End If
        End If
    Next task
    
    ' 准备原任务状态
    OutlineShowAllTasks
    GroupClear
    ' 标记原任务为非临时任务
    For Each task In ActiveProject.Tasks
        If Not task Is Nothing Then
            task.SetField FieldNameToFieldConstant("Flag1"), False
        End If
    Next task
    ' 隐藏原任务
    For Each task In ActiveProject.Tasks
        If Not task Is Nothing And Not task.Summary Then
            task.Visible = False
        End If
    Next task
    
    ' 创建分组摘要任务及任务副本
    For Each key In uniqueGroups.Keys
        Set newSummary = ActiveProject.Tasks.Add(Name:=key, Before:=ActiveProject.Tasks.Count + 1)
        newSummary.Summary = True
        newSummary.SetField FieldNameToFieldConstant("Flag1"), True
        For Each task In uniqueGroups(key)
            task.Copy
            Set newTask = ActiveProject.Tasks.Paste(After:=newSummary)
            newTask.SetField FieldNameToFieldConstant("Flag1"), True
            newTask.OutlineIndent
        Next task
    Next key
    
    ' 初始折叠所有分组
    OutlineCollapseAllTasks
End Sub

Sub UngroupByString()
    Dim task As Task
    Dim tasksToDelete As New Collection
    
    ' 收集所有临时任务（标记为Flag1=True）
    For Each task In ActiveProject.Tasks
        If Not task Is Nothing And task.GetField(FieldNameToFieldConstant("Flag1")) = True Then
            tasksToDelete.Add task
        End If
    Next task
    
    ' 删除临时任务
    For Each task In tasksToDelete
        task.Delete
    Next task
    
    ' 恢复原视图
    OutlineShowAllTasks
    GroupClear
    
    ' 重置Flag1字段
    For Each task In ActiveProject.Tasks
        If Not task Is Nothing Then
            task.SetField FieldNameToFieldConstant("Flag1"), False
        End If
    Next task
End Sub

核心功能说明 #

• 切换分组状态: 运行GroupTasksByString时会先检查是否已分组，若已分组则自动恢复原视图，否则创建新分组。
• 原任务保护: 原任务仅被隐藏，不会被修改或删除，确保恢复时完全还原。
• 多分组实现: 每个分组对应一个摘要任务，任务会被复制到所属的所有分组下，支持同一任务出现在多个分组中。
• 临时任务标记: 使用Flag1字段区分临时任务，方便取消分组时批量清理。

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