You may use the following script, that (re)sets the Nonworking Flag in the
Personal Calender of a resource, based on the Actual Work entered (possibly
via timesheets) on a task with a format like "2005 Vacation":
Sub UpdatePersonalCalendars()
'The Personal Calendars of resources, assigned to a task "xxxx
Holiday..." are updated with the following logic:
'if future Actual Work >= Avail, PersonalCalendar.Working is set to
False (timephased data)
'if past Actual Work >= Avail, PersonalCalendar is set to Default
(timephased data)
AbsenceTaskNames = Array("Company Holiday", "Personal Holiday",
"Vacation", "Holiday", "Sickness", "Paid Leave", "Unpaid Leave")
Dim tsk As Task
Dim res As Resource
Dim asn As Assignment
Dim tsv As TimeScaleValue
Dim ModifyRes As String
Dim pr As Project
ModifyRes = ";"
'collect Resource IDs of resources requiring an update in the Enterprise
Resource Pool
For Each tsk In ActiveProject.Tasks
If doUpdate(tsk.Name, AbsenceTaskNames) Then
For Each asn In tsk.Assignments
If Not
ActiveProject.Resources(asn.ResourceName).EnterpriseInactive And _
ActiveProject.Resources(asn.ResourceName).Type =
pjResourceTypeWork Then
If InStr(1, ModifyRes, CStr(";" &
ActiveProject.Resources(asn.ResourceName).EnterpriseUniqueID & ";")) = 0 Then
ModifyRes = ModifyRes &
ActiveProject.Resources(asn.ResourceName).EnterpriseUniqueID & ";"
End If
End If
Next asn
End If
Next tsk
'Open the Enterprise Resource Pool for the selected resources, update
and save
If Len(ModifyRes) > 2 Then
ModifyRes = Mid(ModifyRes, 2, Len(ModifyRes) - 2)
'ModifyRes = Left(ModifyRes, Len(ModifyRes) - 1) 'deleting leading
and trailing ";"
Set pr = ActiveProject
EnterpriseResourcesOpen euid:=ModifyRes 'Enterprise Resource
Pool becomes ActiveProject
For Each res In ActiveProject.Resources
'reset non-working flag to default to reflect past and future
(adjusted) of actuals
Dim td As Integer
vStart = CDate(pr.ProjectSummaryTask.Start)
For td = 0 To DateDiff("d", pr.ProjectSummaryTask.Start,
pr.ProjectSummaryTask.Finish)
res.Calendar.Years(Year(vStart + td)).Months(Month(vStart +
td)).Days(Day(vStart + td)).Default
Next td
'change Personal Calendar for assignments after yesterday
For Each asn In pr.Resources(res.Name).Assignments
If asn.Finish >= Date Then
If doUpdate(asn.TaskName, AbsenceTaskNames) Then
For Each tsv In asn.TimeScaleData(Date, asn.Finish,
pjAssignmentTimescaledActualWork, TimescaleUnit:=pjTimescaleDays)
If IsNumeric(tsv.Value) Then
If tsv.Value > 0 Then
If tsv.Value >=
res.TimeScaleData(tsv.StartDate, tsv.StartDate,
pjResourceTimescaledWorkAvailability,
TimescaleUnit:=pjTimescaleDays).Item(1).Value Then
res.Calendar.Years(Year(tsv.StartDate)).Months(Month(tsv.StartDate)).Days(Day(tsv.StartDate)).Working = False
End If
End If
End If
Next tsv
End If
End If
Next asn
Next res
FileClose pjSave
End If
End Sub
Function doUpdate(str As String, strs As Variant) As Boolean
Dim i As Integer
doUpdate = False
For i = LBound(strs) To UBound(strs)
If Mid(str, 6) = strs(i) Then
doUpdate = True
Exit For
End If
Next i
End Function
