1

I'm writing an MS Project macro that reads that reads in a .csv file of resource data showing the remaining hours for each resource on each task that they're assigned to, then calculates the start and end date based on the number of hours remaining and updates the timescalevalues for the corresponding task/resource/assignment after some basic calculations on how many days & hours per day to fill for the given number of hours. Start & end date, hours per day and days to fill are calculated differently based on whether the task exists in the project already or needs to be created, and whether the task changes when reading in the sorted data file.

.csv file screenshot

The code works exactly as it should when I test it with one single line item in the date file. Then when I add a second line item to the data file for the same task but different resource, it stores that correctly as well, but it changes the first value on the first resource that was correctly stored.

Project screenshot after running macro with above data

Both data lines had 2 hours, if I run the code with only the first entry, 2 hours is entered but with both it switches to 0.4. If I run it with both and break out of the code while running before it updates for the second line, it has 2 hours.

Sub ImportTimesheetDataProjected()

    Dim proj As Project
    Set proj = Application.ActiveProject
    Set xlApp = New Excel.Application

    Dim filePath As Variant
    Dim fd As FileDialog

    Set fd = xlApp.FileDialog(msoFileDialogFilePicker)

    fd.Title = "Select data file"
    fd.Filters.Clear
    fd.Filters.Add "CSV Files", "*.csv", 1
    fd.Show
    filePath = fd.SelectedItems(1)

    If filePath <> "" Then

        Application.Calculation = pjManual
        Application.ScreenUpdating = False

        ReadTimesheetDataAndUpdateProject proj, filePath

        Application.Calculation = pjAutomatic
        Application.ScreenUpdating = True
    
        MsgBox "Timesheet data updated successfully.", vbInformation
    Else
        MsgBox "No file selected. Operation canceled.", vbInformation
    End If
End Sub

Sub ReadTimesheetDataAndUpdateProject(proj As Project, filePath As Variant)

    Dim excelApp As Object
    Set excelApp = CreateObject("Excel.Application")

    Dim wb As Excel.Workbook
    Set wb = excelApp.Workbooks.Open(filePath)

    Dim ws As Excel.Worksheet
    Set ws = wb.Worksheets(1)

    'Time data sorting code omitted

    Dim rowIndex As Long
    Dim lastRowIndex As Long
    lastRowIndex = ws.Cells(ws.Cells.Rows.Count, 1).End(-4162).Row

    Dim taskName As String
    Dim prevTaskName As String
    prevTaskName = ""
    Dim task As task
    Dim resourceName As String
    Dim prevResourceName As String
    Dim assignment As assignment
    Dim resource As resource
    Dim ts As TimeScaleValues
    Dim tsIndex As Long
    Dim startDate As Date
    Dim endDate As Date
    Dim found As Boolean
    Dim workingDays As Long
    Dim totalDays As Long
    Dim hoursPerDay As Variant
    Dim lastCellFlag As Boolean

    rowIndex = 2
    Do While rowIndex <= lastRowIndex
        taskName = ws.Cells(rowIndex, 2).Value & " - " & ws.Cells(rowIndex, 3).Value & " - " & ws.Cells(rowIndex, 4).Value
        resourceName = ws.Cells(rowIndex, 5).Value
    
        If ws.Cells(rowIndex, 6).Value > 0 Then

            If taskName <> prevTaskName Then

                workingDays = excelApp.WorksheetFunction.RoundUp(ws.Cells(rowIndex, 6).Value / 7.6, 0)
            
                found = Find(Field:="Name", Test:="equals", Value:=taskName)

                If found Then
                    Set task = ActiveCell.task
                    startDate = Int(proj.StatusDate + 1)
                    totalDays = getTotalDays(workingDays, startDate)
                    If startDate + totalDays > task.Finish Then
                        endDate = startDate + totalDays
                        task.Finish = endDate
                        hoursPerDay = 7.6
                        lastCellFlag = True
                    Else
                        endDate = Int(task.Finish)
                        hoursPerDay = ws.Cells(rowIndex, 6).Value / getWorkingDays(startDate, endDate)
                        lastCellFlag = False
                    End If

                Else
                    Set task = proj.Tasks.Add(taskName)
                    task.Type = pjFixedWork
                    startDate = Date
                    task.Start = startDate
                    totalDays = getTotalDays(workingDays, startDate)
                    endDate = Date + totalDays
                    task.Finish = endDate
                    hoursPerDay = 7.6
                    lastCellFlag = True
                End If
            Else
                totalDays = getTotalDays(workingDays, startDate)
                If startDate + totalDays > task.Finish Then
                    endDate = Int(startDate + totalDays)
                    task.Finish = endDate
                    hoursPerDay = 7.6
                    lastCellFlag = True
                Else
                    hoursPerDay = ws.Cells(rowIndex, 6).Value / getWorkingDays(startDate, endDate)
                    lastCellFlag = False
                End If
            End If
        
            Set resource = FindOrCreateResource(proj, resourceName)
            Set assignment = FindOrAddResourceToTask(task, resource)
            Set ts = assignment.TimeScaleData(startDate:=startDate, endDate:=endDate, Type:=pjAssignmentTimescaledWork, TimeScaleUnit:=pjTimescaleDays)
            tsIndex = 1
            Do While tsIndex < ts.Count
                If Format(ts(tsIndex).startDate, "ddd") <> "Sat" And Format(ts(tsIndex).startDate, "ddd") <> "Sun" Then
                    ts(tsIndex).Value = hoursPerDay * 60
                End If
                tsIndex = tsIndex + 1
            Loop
            If lastCellFlag Then
                ts(tsIndex).Value = (((ws.Cells(rowIndex, 6).Value * 100) Mod 760) / 100) * 60
            Else
                ts(tsIndex).Value = hoursPerDay * 60
            End If
        
            prevTaskName = taskName
        End If

        rowIndex = rowIndex + 1
    
    Loop

    wb.Save
    wb.Close

    excelApp.Quit
End Sub

Function FindOrCreateResource(proj As Project, resourceName As String) As resource
    Dim resource As resource
    Dim found As Boolean

    For Each res In proj.Resources
        If res.Name = resourceName Then
            Set resource = res
            Exit For
        End If
    Next res

    If resource Is Nothing Then
        Set resource = proj.Resources.Add(resourceName)
    End If

    Set FindOrCreateResource = resource
End Function

Function FindOrAddResourceToTask(task As task, resource As resource) As assignment
    For Each assignment In task.Assignments
        If assignment.resourceName = resource.Name Then
            Set FindOrAddResourceToTask = assignment
            Exit Function
        End If
    Next assignment

    Set FindOrAddResourceToTask = task.Assignments.Add(ResourceID:=resource.ID)
End Function

Function getTotalDays(totalDays As Long, startDate As Date) As Long

    Dim i As Long
    i = 0
    Do While i < totalDays
        If Format(startDate + i, "ddd") = "Sat" Or Format(startDate + i, "ddd") = "Sun" Then
           totalDays = totalDays + 1
        End If
        i = i + 1
    Loop

    getTotalDays = totalDays

End Function

Function getWorkingDays(startDate As Date, endDate As Date) As Long
    Dim totalDays As Long
    Dim workingDays As Long
    Dim i As Long
    totalDays = DateDiff("d", startDate, endDate)
    workingDays = totalDays
    i = 0
    Do While i < totalDays
        If Format(startDate + i, "ddd") = "Sat" Or Format(startDate + i, "ddd") = "Sun" Then
            workingDays = workingDays - 1
        End If
        i = i + 1
    Loop

    getWorkingDays = workingDays

End Function

The code runs but likely contains some very minor errors in the date and hours calculations that I can't debug until I solve this.

Initially I did tried setting the start and end date for the task and updating the 'RemaingHours' for the assignment directly but I had the same problem with values changing. I'd be happy if I can update the 'Work' with the correct remaining hours for each data line regardless of duration.

Many thanks in advance.

Edited as requested - greatly appreciate your time

RadTunesly
  • 23
  • 3
  • 1
    Without seeing the code and a sample of your schedule and input (last two can be screenshots), it's hard to say what's going on. Edit your question to include those items. For the code, only show the relevant parts. You can remove comments and excessive blank lines to make it shorter. (The Edit button is in grey and is located between your post and this comment.) – Rachel Hettinger Jun 20 '23 at 12:40
  • The changing of values seems to happen only when the task type is Fixed Duration. In my testing, Fixed Units and Fixed Work did not have the issue. – Rachel Hettinger Jun 21 '23 at 16:07

2 Answers2

0

Here is the original code with a few changes. Namely:

Suggest testing the code on a very simple project that uses a standard 8-hour day. Once that is working, try it out on the schedules that use a 7.6-hour day.

Whenever possible, use Task Types of Fixed Units or Fixed Work as Fixed Duration tasks with multiple resources have the issue whereby changing one assignment causes Project to change other assignments on the same task.

Dim xlApp As Excel.Application

Sub ImportTimesheetDataProjected()

    Dim proj As Project
    Set proj = Application.ActiveProject
    Set xlApp = New Excel.Application

    Dim filePath As Variant
    Dim fd As FileDialog

    Set fd = xlApp.FileDialog(msoFileDialogFilePicker)

    fd.Title = "Select data file"
    fd.Filters.Clear
    fd.Filters.Add "CSV Files", "*.csv", 1
    fd.Show
    filePath = fd.SelectedItems(1)

    If filePath <> "" Then

        Application.Calculation = pjManual
        Application.ScreenUpdating = False

        ReadTimesheetDataAndUpdateProject proj, filePath

        Application.Calculation = pjAutomatic
        Application.ScreenUpdating = True
    
        MsgBox "Timesheet data updated successfully.", vbInformation
    Else
        MsgBox "No file selected. Operation canceled.", vbInformation
    End If
End Sub

Sub ReadTimesheetDataAndUpdateProject(proj As Project, filePath As Variant)

    Dim wb As Excel.Workbook
    Set wb = xlApp.Workbooks.Open(filePath)

    Dim ws As Excel.Worksheet
    Set ws = wb.Worksheets(1)

    'Time data sorting code omitted

    Dim rowIndex As Long
    Dim lastRowIndex As Long
    lastRowIndex = ws.Cells(ws.Cells.Rows.Count, 1).End(-4162).Row

    Dim taskName As String
    Dim prevTaskName As String
    prevTaskName = ""
    Dim t As task
    Dim resourceName As String
    Dim prevResourceName As String
    Dim a As assignment
    Dim r As resource
    Dim ts As TimeScaleValues
    Dim tsIndex As Long
    Dim startDate As Date
    Dim found As Boolean
    Dim workingDays As Long  ' this is remaining days per the csv file
    Dim hoursPerDay As Variant
    Dim lastCellFlag As Boolean
    Dim estFinish As Date
                    
    Dim cal As Calendar
    Set cal = proj.Calendar
    
    rowIndex = 2
    Do While rowIndex <= lastRowIndex
        'taskName = ws.Cells(rowIndex, 2).Value & " - " & ws.Cells(rowIndex, 3).Value & " - " & ws.Cells(rowIndex, 4).Value
        taskName = ws.Cells(rowIndex, 2).Value
        resourceName = ws.Cells(rowIndex, 5).Value
    
        If ws.Cells(rowIndex, 6).Value > 0 Then

            If taskName <> prevTaskName Then

                workingDays = xlApp.WorksheetFunction.RoundUp(ws.Cells(rowIndex, 6).Value / 7.6, 0)
            
                found = Find(Field:="Name", Test:="equals", Value:=taskName)

                If found Then
                    Set t = ActiveCell.task
                    startDate = Int(proj.StatusDate + 1)
                    estFinish = Application.DateAdd(startDate, workingDays * (7.6 * 60))
                    If estFinish > t.Finish Then
                        t.Finish = estFinish
                        hoursPerDay = 7.6
                        lastCellFlag = True
                    Else
                        hoursPerDay = ws.Cells(rowIndex, 6).Value / (Application.DateDifference(startDate, t.Finish) / (7.6 * 60))
                        lastCellFlag = False
                    End If
                Else
                    Set t = proj.Tasks.Add(taskName)
                    t.Type = pjFixedWork
                    startDate = Date
                    t.Start = startDate
                    t.Duration = workingDays
                    hoursPerDay = 7.6
                    lastCellFlag = True
                End If
            
            Else
                estFinish = Application.DateAdd(startDate, workingDays)
                If estFinish > t.Finish Then
                    t.Finish = estFinish
                    hoursPerDay = 7.6
                    lastCellFlag = True
                Else
                    hoursPerDay = ws.Cells(rowIndex, 6).Value / (Application.DateDifference(startDate, t.Finish) / (7.6 * 60))
                    lastCellFlag = False
                End If
            End If
            
            Set r = FindOrCreateResource(proj, resourceName)
            Set a = FindOrAddResourceToTask(t, r)
            Set ts = a.TimeScaleData(startDate:=startDate, endDate:=Int(t.Finish) + 1, Type:=pjAssignmentTimescaledWork, TimeScaleUnit:=pjTimescaleDays)
            tsIndex = 1
            Do While tsIndex < ts.Count
                If cal.Period(ts(tsIndex).startDate).Working Then
                    ts(tsIndex).Value = hoursPerDay * 60
                End If
                tsIndex = tsIndex + 1
            Loop
            If lastCellFlag And cal.Period(ts(tsIndex).startDate).Working Then
                ts(tsIndex).Value = (((ws.Cells(rowIndex, 6).Value * 100) Mod 760) / 100) * 60
            Else
                ts(tsIndex).Value = hoursPerDay * 60
            End If
            
            prevTaskName = taskName
        End If

        rowIndex = rowIndex + 1
    
    Loop

    wb.Save
    wb.Close False

    xlApp.Quit
End Sub

Function FindOrCreateResource(proj As Project, resourceName As String) As resource
    Dim resource As resource
    Dim found As Boolean

    Dim res As resource
    For Each res In proj.Resources
        If res.Name = resourceName Then
            Set resource = res
            Exit For
        End If
    Next res

    If resource Is Nothing Then
        Set resource = proj.Resources.Add(resourceName)
    End If

    Set FindOrCreateResource = resource
End Function

Function FindOrAddResourceToTask(t As task, r As resource) As assignment
    Dim a As assignment
    For Each a In t.Assignments
        If a.resourceName = r.Name Then
            Set FindOrAddResourceToTask = a
            Exit Function
        End If
    Next a

    Set FindOrAddResourceToTask = t.Assignments.Add(ResourceID:=r.ID)
End Function
Rachel Hettinger
  • 7,927
  • 2
  • 21
  • 31
  • Thanks Rachel, that seems to have done the trick. I've had a quick play around to see if I can find out what was different as my tasks are all set to FixedWork including the newly created ones. I'm pretty sure it was defining the task duration. The Period object was an excellent suggestion, can't believe I went to all the trouble of determining working days unnecessarily. And yes, variable names as key words is terrible practice. Really appreciate your help I hadn't touched Project prior to 3 months ago and barely coded in VBA prior to one month. Your posts have taught me 90% of what I know. – RadTunesly Jun 22 '23 at 08:36
  • I did mean to ask, what is the purpose of adding 1 to the 'endDate' when calling the TimeScaleData function? – RadTunesly Jun 22 '23 at 08:47
  • The endDate parameter should be thought of as date/time because if it is truncated, by using Int, the time component is midnight which leaves no working time that day and there will be one fewer days in the collection of TimeScaleValues. Probably leaving it as `endDate:=t.Finish` would be sufficient, and perhaps better. I had added the +1 (`endDate:=endDate + 1`) and then later swapped out t.Finish for endDate without revisiting how it was used in the TimeScaleData method. – Rachel Hettinger Jun 22 '23 at 12:29
  • And wow, you are off to a great start only a few months into VBA & Project! – Rachel Hettinger Jun 22 '23 at 12:31
0

I did find the answer to my question eventually. The Boolean 'EffortDriven' property of a task is what was changing the timescalevalues of the work. Setting this property to 'false' and the task type to 'FixedDuration' or 'FixedUnits' stops the timescalevalues updating when changes are made to another assignment on the same task.

I did just stumble across the same answer here after I had figured it out for myself.

RadTunesly
  • 23
  • 3