3
\$\begingroup\$

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.

| improve this question | | | | |
\$\endgroup\$
  • 3
    \$\begingroup\$ You have two loops, so 1500 * 1500 or 2000 * 2000 = 2,250,000 to 4,000,000 iterations. \$\endgroup\$ – BigBen Feb 13 at 14:15
  • \$\begingroup\$ Indeed, but shouldn't 4mil operations be a breeze for a 2,4 ghz processor? \$\endgroup\$ – Marcin Feb 13 at 14:17
2
\$\begingroup\$

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
| improve this answer | | | | |
\$\endgroup\$
  • \$\begingroup\$ Works! Nice thank You. \$\endgroup\$ – Marcin Feb 17 at 12:08
7
\$\begingroup\$

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
| improve this answer | | | | |
\$\endgroup\$
3
\$\begingroup\$

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.

| improve this answer | | | | |
\$\endgroup\$
3
\$\begingroup\$

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.

| improve this answer | | | | |
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.