Find duplicated text for tasks in MS Project

Question

My code in MS project VBA, in theory, doesn't do anything major.
It compares the tasks with each other, but it runs super slow.

One run through Temp lasts 15 secs. Try that with 1500-2000 tasks and the macro takes hours.

Sub Laczona()

Application.Calculation = xlManual
Application.ScreenUpdating = False

Dim Temp, Temp2 As Integer


For Temp = 1 To ActiveProject.Tasks.Count

For Temp2 = 1 To ActiveProject.Tasks.Count

If ActiveProject.Tasks(Temp).Text30 = ActiveProject.Tasks(Temp2).Text30 Then
If Temp <> Temp2 Then
ActiveProject.Tasks(Temp).Flag5 = 1
End If
End If

Next Temp2
MsgBox "Praca: " & Temp
Next Temp

MsgBox "Prace Laczone Uzupelnione"
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic

End Sub

Addidional explanation:
The code runs in MS Project 2013. Its purpose is to check whether two tasks have the same text in field Text30. If that is the case, the code sets flag5 to 1.

You have two loops, so 1500 * 1500 or 2000 * 2000 = 2,250,000 to 4,000,000 iterations. — BigBen
– BigBen, Commented Feb 13, 2020 at 14:15
Indeed, but shouldn't 4mil operations be a breeze for a 2,4 ghz processor? — Marcin
– Marcin, Commented Feb 13, 2020 at 14:17

PeterT · Accepted Answer · 2020-02-13 15:46:08Z

In a slightly different implementation from @FreeFlow's answer, this code also uses a Dictionary but it builds a list of duplicate tasks for each Text30 value. Then uses that task list to set Flag5. Tested on a very large project (>1100 tasks) it runs in less than 15 seconds.

Option Explicit

Sub CheckForDuplicates()

    Application.Calculation = pjManual
    Application.ScreenUpdating = False

    Dim text30values As Dictionary
    Set text30values = New Dictionary

    Dim taskList As String
    With ActiveProject
        '--- for each of the text30 values, create a list of tasks that contain
        '    each value. For example, if "abc" appears in tasks 17,18,23, and 50
        Dim i As Long
        For i = 1 To .Tasks.Count
            If .Tasks(i).Text30 <> vbNullString Then
                If text30values.Exists(.Tasks(i).Text30) Then
                    taskList = text30values(.Tasks(i).Text30) & "," & i
                    text30values(.Tasks(i).Text30) = taskList
                Else
                    text30values.Add Key:=.Tasks(i).Text30, Item:=i
                End If
            End If
        Next i

        '--- now run through each entry and set the flag field for the duplicates
        '    entries with duplicates will be CSV lists, so we're looking for a comma
        For i = 0 To text30values.Count - 1
            taskList = text30values.Items(i)
            If InStr(1, taskList, ",") > 0 Then
                Dim theTasks As Variant
                theTasks = Split(taskList, ",")
                Dim j As Long
                For j = LBound(theTasks) To UBound(theTasks)
                    .Tasks(CLng(theTasks(j))).Flag5 = 1
                Next j
            End If
        Next i
    End With

    Application.Calculation = pjAutomatic
    Application.ScreenUpdating = True
End Sub

Freeflow · Accepted Answer · 2020-02-13 14:56:39Z

If I understand correctly, you are testing to see if there are any duplicate entries in Text30 and if you find a duplicate setting flag 5 to 1.

In this case you are duplicating at least half of the tests that you are conducting because Task(1).Text(30) = Task(2).Text30 is the same comparison as Tasks(2).Text30 = Task(1).Text30.

So you can cut down on the number of tests that you do by eliminating tests that you have already performed. This is done by starting the inner loop at the current value of the outer loop.

e.g.

For Temp2 = 1 To ActiveProject.Tasks.Count

should be revised to

For Temp2 = Temp To ActiveProject.Tasks.Count

However an even quicker way would be to use a Scripting.Dictionary. I don't have project installed on my PC but even so if the code below doesn't work it should at least point you in the right direction

Sub Lacunza()

    Dim myUniqueText30 As Scripting.Dictionary
    Set myUniqueText30 = New Scripting.Dictionary

    Dim myTask As Long
    For myTask = 1 To ActiveProject.Tasks.Count

        With ActiveDocument.Tasks(myTask)

            If myUniqueText30.Exists(.Text30) Then

                .Flag5 = 1

            Else

                myUniqueText30.Add Key:=.Text30, Item:=myTask

            End If

    Next

    ' As this point you have a scripting dictionary which will return the task id
    ' where the first occurence of a particular Text30 value was found.

End Sub

this · Accepted Answer · 2020-02-13 15:18:39Z

4

I am not familiar with Project VBA, but wouldn't it be much faster to use filters and iterate that instead?

Filters object

IOW, don't try to brute-solve it. Learn the object model and find the object/method that will help you do it since their implementation will be much faster than any loops you come up with, on average.

answered Feb 13, 2020 at 15:18

this

2,03914 silver badges24 bronze badges

Add a comment |

Joop Eggen · Accepted Answer · 2020-02-13 15:20:21Z

An immediately obvious improvement would be to start the inner loop from Temp+1.

Sub Laczona()
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Dim Temp, Temp2 As Integer
    Dim text30 As String
    For Temp = 1 To ActiveProject.Tasks.Count
        If ActiveProject.Tasks(Temp).Flag5 <> 1 Then
            text30 = ActiveProject.Tasks(Temp).Text30;
            For Temp2 = Temp + 1 To ActiveProject.Tasks.Count
                If ActiveProject.Tasks(Temp2).Flag5 <> 1
                        And text30 = ActiveProject.Tasks(Temp2).Text30 Then
                    ActiveProject.Tasks(Temp).Flag5 = 1
                    ActiveProject.Tasks(Temp2).Flag5 = 1
                End If
            Next Temp2
        End If
        'MsgBox "Praca: " & Temp
    Next Temp
    MsgBox "Prace Laczone Uzupelnione"
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub

Still quadratic complexity. Sorting on Text30 would really improve the speed, but whether that is feasible; you would need an extra index etcetera I do not know.

Above I checked Flag5 too, as that might be faster - or just as likely not.

MsgBox in a loop probably was only for testing.

Stack Exchange Network

Find duplicated text for tasks in MS Project

4 Answers 4

You must log in to answer this question.

Hot Network Questions

Find duplicated text for tasks in MS Project

4 Answers 4

You must log in to answer this question.

Related

Hot Network Questions