Updating Start, Finish % Complete from excel file to Ms Project

Question

Hi - This is my first post on this forum which i see is a great way to share knowledge.
I’m having a schedule which has around 3000 lines with resources names and a Responsible Person (  where individual resources
report to) updated on the schedule.
I need to work out a good way to get schedule updates from different parties in a efficient way.
My thoughts are to make a solution to generate the tasks which needs to be updated based on the status date and generate a individual excel files for each responsible person and get
their updates back in excel and update the dates and % complete back to the MS Project schedule.<o:p></o:p>
The steps
a) create a filter to list all the tasks which need to be updated based status date ( tasks which are in progress, tasks in the past which have not started yet,
tasks in the past which have finished etc) grouped as per responsible person and create separate excel files for each responsible person.
b) the excel file will contain ( UID, Task name, start date, finish date, %complete, resource name, responsible person)
c) I would like to email these excel files to each responsible person and get their updates for (start date, finish date, %complete)
d) Create a VBA macro to let the user to select the updated excel file and update the data back to MS Project file.
Conditions while updating
a)  
Read the Excel file from Top to bottom and find the correct record based on the UID and update the "duration" in order to change dates as below
b)  
IF Task has started ( the excel file contains % complete and a new start date later than the MS Project start date)
Update MS Project file ( Actual Start date and % Complete)
c)  
IF Task has started as Scheduled ( the excel file contain % complete and the excel file start date is equal to MS Project start date)
        Update MS Project file ( Actual Start date and % Complete)
d)  
IF Task has started and finished as Scheduled ( The excel file start and finish dates are equal to MS Project file but excel file % complete is now 100%)
Update MS Project File ( Actual Start, Actual Finish and Update % Complete 100%)
e)  
If Start date of the task has been rescheduled to a future date ( If Excel file start date is > that Ms project start date and excel file % complete is 0)
Update the MS Project file and inset a lag to match the excel file start date.
I would like to know whether this would be a feasible solutions and if some of you have implemented this kind of thing please share some code snippets.
Thanks a lot

Answer 1

Hi John, I've managed to progress further on the code and Split the records as per supervisor and create excel file and email  to supervisor.
However I ran into 2 problems
1) The code  works some time without any error and some times it stalls. I have managed to narrow it down to the sorting code block on the
ExportTaskstobeUpdated mehod where it Selects the Active work book which has all the data based on the filter and Sorts according to Supervisor Name+ Resource Name
I have made the error code Bold and Italic
The error I'm getting is
Run-time error '1004'
Method'Range' of object'_Global' failed
2) Currently I'm creating the Master Excel file which is generated by the
ExportTaskstobeUpdated method and splitting them and creating all the splits + the Master  excel file to a hard coded locationwhich is C:GESProjectEmail folder
When Saving it Prompts to Over wright the existing files , I don't need any prompts coming out for the user.
I've tried using the Application.DisplayAlearts=False but it does not work for me.
In order to overcome this , I created a routine to delete the files after the files have been emailed/Saved as draft but that too fails to delete the original Master excel file.
Is there a way to generate the excel files on the fly and without saving can I attach it to the email ?
Or would like to know your thoughts on a better way to handle this.
Sub ExportTaskstoBeUpdated()
'Start Excel and create a new workbook
'Create column titles
'Export data and the project title
'Tidy up
Dim xlApp As Excel.Application
Dim xlRange As Excel.Range
Dim Dept As Task
Dim Check As String
Dim Prime As String
Dim PrimeEmail As String
Dim OpeningParen, ClosingParen As Integer
'Start Excel and create a new workbook
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Add
'Create column titles
Set xlRange = xlApp.Range("A1")
With xlRange
'.Formula = "Master Schedule Report"
.Font.Bold = True
.Font.Size = 12
.Select
End With
xlRange.Range("A1") = "Supervisor"
xlRange.Range("B1") = "Resource Name"
xlRange.Range("C1") = "UID"
xlRange.Range("D1") = "Task Name"
xlRange.Range("E1") = "Start Date"
xlRange.Range("F1") = "Finish Date"
xlRange.Range("G1") = "% Completed"
xlRange.Range("H1") = "Project"
xlRange.Range("I1") = "Supervisor Email"
With xlRange.Range("A1:N1")
.Font.Bold = True
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
.EntireColumn.AutoFit
.Select
End With
'Export data and the project title
Set xlRange = xlRange.Range("A2") 'Set cursor to the right spot in the worksheet
ViewApply Name:="Task Sheet" 'Get the view that has the Text11 column to filter on
OutlineShowAllTasks 'Any hidden tasks won't be selected, so be sure all tasks are showing
FilterApply Name:=" Telstra - CHECK 5 - Unstatused Tasks" 'This custom filter selects "External"
SelectTaskColumn ("Text2") 'Insures the For Each loop gets all of the filtered tasks, this may be redundant
For Each Dept In ActiveSelection.Tasks 'Pulls data for each task into spreadsheet
If Dept.Text4 <> "" Then ' If there is no Supervisor defined ignore the Task
With xlRange
.Range("A1") = Dept.Text4 ' Supervisor Name, which has a Lookup , where the description on the lookup is the Supervisor Email
.Range("B1") = Dept.ResourceNames
.Range("C1") = Dept.Text1
.Range("D1") = Dept.Name
.Range("E1") = Format(Dept.Start, "dd-mmm-yyyy")
.Range("F1") = Format(Dept.Finish, "dd-mmm-yyyy")
.Range("G1") = Dept.PercentComplete
.Range("H1") = ActiveProject.Name
'This below Code Developed by John Finds the lookup description value for a custom field value
If Dept.Text4 <> "" Then 'This is not required now since its captured above
Dim Found As Boolean
Dim i As Integer, NumSup As Integer
NumSup = ActiveProject.Resources.Count
'Once you have that set up, now you can add this code to your macro to determine the value for the "I1" range.
On Error Resume Next
'cycle through each item in the value list to find the one selected for this task
For i = 1 To NumSup
'once the item is found exit the loop
If CustomFieldValueListGetItem(pjCustomTaskText4, pjValueListValue, i) = _
Dept.Text4 Then
'the loop can exit for two reasons, one, the item has been found, two,
' the item was not found and an error occurred. We need to distinguish between the two
If Err = 0 Then Found = True
Exit For
End If
Next
On Error GoTo 0 'this resets the err function
'now that the corresponding email address is found, set the Excel range value
If Found Then
.Range("I1") = CustomFieldValueListGetItem(pjCustomTaskText4, pjValueListDescription, i)
Else
.Range("I1") = "No Email Defined"
End If
End If
'=====================
End With
Set xlRange = xlRange.Offset(1, 0) 'Point to next row
Else
End If
Next Dept
'Tidy up
FilterApply Name:="All Tasks"
ViewApply Name:="Task Sheet"
With xlRange
.Range("A1").ColumnWidth = 30
.Range("D1").ColumnWidth = 50
.Range("E1").ColumnWidth = 20
.Range("F1").ColumnWidth = 20
.Range("G1").ColumnWidth = 20
.Range("H1").ColumnWidth = 30
End With
'Sort the Active work book for Supervisor Name + Resource Name
Range("A1:I1").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A500") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2:B500") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:I500")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set xlApp = Nothing
'Call Method to Split to seperate files and Email
SplitIntoSeparateFiles
'Call the Method to delete the excel files genearated by the above method
Deletefiles
End Sub
Sub SplitIntoSeparateFiles()
'* This method Split the Master excel file which is sorted by Supervisor Name + Resource Name
Dim OutBook, MyWorkbook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim FilterRange As Range
Dim UniqueNames As New Collection
Dim LastRow As Long, LastCol As Long, _
NameCol As Long, Index As Long
Dim OutName, MasterOutName, SupervisorEmail As String
'set references and variables up-front for ease-of-use
'the current workbook is the one with the primary data, more workbooks will be created later
Set MyWorkbook = ActiveWorkbook
Set DataSheet = ActiveSheet
NameCol = 1 ' This is supervisor Name which will be splitted
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set FilterRange = Range(DataSheet.Cells(1, NameCol), DataSheet.Cells(LastRow, LastCol))
'loop through the name column and store unique names in a collection
For Index = 2 To LastRow
On Error Resume Next
UniqueNames.Add Item:=DataSheet.Cells(Index, NameCol), Key:=DataSheet.Cells(Index, NameCol)
On Error GoTo 0
Next Index
'iterate through the unique names collection, writing
'to new workbooks and saving as the group name .xls
Application.DisplayAlerts = False
For Index = 1 To UniqueNames.Count
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)
With FilterRange
.AutoFilter Field:=NameCol, Criteria1:=UniqueNames(Index)
.SpecialCells(xlCellTypeVisible).Copy OutSheet.Range("A1")
End With
OutName = "C:\GESProjectEmail" + "\" 'Path to Save the generated file
SupervisorEmail = OutSheet.Range("I2") 'Supervisor Email
MasterOutName = OutName & "Test" ' This is the First excel file generated by the ExportTasksto Be Updated Method
OutName = OutName & UniqueNames(Index) & Trim(I2)
Application.DisplayAlerts = False
OutBook.SaveAs FileName:=OutName, FileFormat:=xlExcel8 'Create Excel files for each splitted files and save
'Call Send Email method
Send_Email_Current_Workbook (SupervisorEmail)
OutBook.Close SaveChanges:=False
Call ClearAllFilters(DataSheet)
Next Index
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=MasterOutName, FileFormat:=xlExcel8
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Sub Send_Email_Current_Workbook(Email As String)
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Email
.CC = ""
.BCC = ""
.Subject = "Project Status Update"
.Body = "Please Update the attached file and email it back to the PM"
.Attachments.Add ActiveWorkbook.FullName
.Save
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'safely clear all the filters on data sheet
Sub ClearAllFilters(TargetSheet As Worksheet)
With TargetSheet
TargetSheet.AutoFilterMode = False
If .FilterMode Then
.ShowAllData
End If
End With
End Sub
Sub Deletefiles()
' This method is to delete the excel files once its saved and to avoid the DO you want to overigt message
' because Application.DisplayAlerts = False command still prompts the user to save
On Error Resume Next
Kill "C:\GESProjectEmail\*.xl*"
On Error GoTo 0
End Sub