I have a macro which is designed to ensure that the rows in an MS Project plan do not have duplicate names. At the moment this is designed to run across the whole plan and hence uses:
for each t in ActiveProject.tasks
code
Next t
It occurs to me that it could be nice to run this only on a specific set of tasks if a range of more than 1 tasks has been selected by the user, or to offer this option via a choice dialogue box.
How could I do this without needing to copy and paste the entire code set for ActiveSelection?
The full code, in case anyone finds it useful or has some better ways of doing things:
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 (Suffix)", "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
To allow the user to opt between all tasks and selected tasks, a collection needs to be built to hold the respective set. Then the de-duplication code runs on that set.
This code loops through the tasks only once, finding duplicates by using the fact that collections cannot contain duplicate keys. Once a duplicate is found, the first instance of that task name is de-duplicated then the current one.
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