我有一个宏，旨在确保 MS Project 计划中的行没有重复的名称。目前，这被设计为贯穿整个计划，因此使用：
for each t in ActiveProject.tasks
code
Next t
我发现，如果用户选择了超过 1 个任务的范围，或者通过选择对话框提供此选项，则仅在一组特定任务上运行此选项可能会很好。
如何在不需要复制并粘贴 ActiveSelection 的整个代码集的情况下执行此操作？
完整的代码，以防有人发现它有用或有更好的方法：
Sub task_names_fully_auto_de_dup()
Dim t As Task
Dim t_test As Task
Dim Dups As New Collection
For Each t In ActiveProject.Tasks
If task_test(t) Then 'check the row is valid (not external or blank)
For Each t_test In ActiveProject.Tasks
If task_test(t_test) Then 'check the row is valid (not external or blank)
'Compare t_test name to t to find dups and add to dups collection
If t_test.Name = t.Name And t_test.ID <> t.ID Then
Dups.Add t.Name 'need to work out how to avoid trying to add the same name more than once
End If
End If
Next t_test
End If
Next t
If Dups.Count = 0 Then
MsgBox ("No duplicates found")
Exit Sub
Else 'offer choices for where the summary names will be added
choice = InputBox("chose where to add the summary names." & vbCrLf & "1 = Before (prefix)" & vbCrLf & "2 = After (Sufix)", "Auto de-duplication of names 1/2", 2)
If choice = 1 Then 'choose prefix
Pre = InputBox("Choose which seperator you would like." & vbCrLf & "1 = Space" & vbCrLf & "2 = Dash" & vbCrLf & "3 = Colon", "Adding text to many tasks 2/2", 2)
Select Case Pre
Case 1
Pre = " "
Case 2
Pre = " - "
Case 3
Pre = ": "
End Select
Else
'chose suffix
Pre = InputBox("Choose which seporator you would like." & vbCrLf & "1 = Space" & vbCrLf & "2 = Dash" & vbCrLf & "3 = Brackets", "Adding text to many tasks 2/2", 3)
Select Case Pre
Case 1
Pre = " "
Case 2
Pre = " - "
Case 3
Pre = " ("
End Select
End If
End If
Dim SummaryName As String
Dim WBS_String() As String
Dim Target_WBS As String
Dim t_wbs As Task
For Each t In ActiveProject.Tasks
If task_test(t) Then 'checks the row is valid
Dim item As Variant
For Each item In Dups
If t.Name = item Then ' the item is a dup; get the next level up's name
If InStr(1, t.WBS, ".") <> 0 Then 'if this is the top level we can't get a name
WBS_String = Split(t.WBS, ".")
ReDim Preserve WBS_String(LBound(WBS_String) To UBound(WBS_String) - 1) 'removes the last element of the WBS
Target_WBS = Join(WBS_String, ".") 're-join the WBS into the target WBS to find
For Each t_wbs In ActiveProject.Tasks ' find the target WBS and grab the name
If task_test(t_wbs) Then
If t_wbs.WBS = Target_WBS Then SummaryName = t_wbs.Name
End If
Next t_wbs
't.Name = t.Name & " (" & SummaryName & ")" 'add the Summary name to the task
If choice = 1 Then t.Name = SummaryName & Pre & t.Name
If choice = 2 Then
If Pre = " (" Then
t.Name = t.Name & Pre & SummaryName & ")"
Else
t.Name = t.Name & Pre & SummaryName
End If
End If
End If
End If
Next item
End If
Next t
End Sub
Function task_test(t As Task) 'use to replace all the indents
task_test = True
If t Is Nothing Then
task_test = False
Else
If t.ExternalTask = True Then task_test = False
End If
End Function
为了允许用户在所有任务和选定任务之间进行选择，需要构建一个集合来保存相应的集合。然后重复数据删除代码在该集合上运行。
此代码仅循环执行一次任务，利用集合不能包含重复键的事实来查找重复项。一旦找到重复项，该任务名称的第一个实例将被删除重复，然后是当前的实例。
Sub task_names_fully_auto_de_dup()
Dim position As String
Dim separator As String
position = InputBox("chose where to add the summary names." & vbCrLf & "1 = Before (prefix)" _
& vbCrLf & "2 = After (suffix)", "Auto de-duplication of names 1/2", 2)
If Len(position) = 0 Then GoTo ExitSub
If position = "1" Then
Dim prefix As String
prefix = InputBox("Choose which separator you would like." & vbCrLf & "1 = Space" _
& vbCrLf & "2 = Dash" & vbCrLf & "3 = Colon", "Adding text to many tasks 2/2", 2)
If Len(prefix) = 0 Then GoTo ExitSub
separator = Choose(CSng(prefix), " ", " - ", ": ")
Else
Dim suffix As String
suffix = InputBox("Choose which separator you would like." & vbCrLf & "1 = Space" _
& vbCrLf & "2 = Dash" & vbCrLf & "3 = Brackets", "Adding text to many tasks 2/2", 3)
If Len(suffix) = 0 Then GoTo ExitSub
separator = Choose(CSng(suffix), " ", " - ", " (")
End If
Dim answer As VbMsgBoxResult
answer = MsgBox("Run de-duplication on entire project (Yes) or only selected tasks (No)?" _
, vbQuestion + vbYesNoCancel, "All tasks or Selected tasks?")
Dim tsks As Variant
Select Case answer
Case Is = vbYes
Set tsks = ActiveProject.Tasks
Case Is = vbNo
Set tsks = ActiveSelection.Tasks
Case Else
GoTo ExitSub
End Select
Dim t As Task
Dim uniqueTaskNames As New Collection
Dim tskFirstInstance As Task
Dim uid As Variant
On Error Resume Next
For Each uid In tsks
Set t = ActiveProject.Tasks.UniqueID(uid)
If Not t.ExternalTask Then
Err.Clear
uniqueTaskNames.Add t.UniqueID, t.Name
If Err.Number <> 0 Then
Set tskFirstInstance = ActiveProject.Tasks.UniqueID(uniqueTaskNames(t.Name))
AddPrefixSuffix position, separator, tskFirstInstance
AddPrefixSuffix position, separator, t
End If
End If
Next uid
ExitSub:
End Sub
Sub AddPrefixSuffix(position As String, separator As String, tsk As Task)
If InStr(tsk.Name, tsk.OutlineParent.Name) = 0 Then
If position = "1" Then
tsk.Name = tsk.OutlineParent.Name & separator & tsk.Name
ElseIf separator = " (" Then
tsk.Name = tsk.Name & separator & tsk.OutlineParent.Name & ")"
Else
tsk.Name = tsk.Name & separator & tsk.OutlineParent.Name
End If
End If
End Sub