Consulting

Results 1 to 5 of 5

Thread: Compare two versions of a Project file

  1. #1

    Post Compare two versions of a Project file

    At one point or another, most Project users end up having to compare two Project files to find the differences. This can be a pain in the neck if you have to do it line by line. And writing a macro to do it is no fun either. So, don't do either one - use this macro already finished and tested. It creates a comparison file in Excel and highlights the differences in red. To install it, copy the code into a new module and add a reference to the Excel Object Library. Then load the oldest of the two files to be compared, and then the later one. Then start the macro and sit back until it finishes. Comparing two files has never been easier!

    Here it is - enjoy! Send me your comments or suggestions, please!

    Sub CompareTwoProjectFiles()
    'This VBA macro for Project was written by Rick Williams
    Dim x As Integer
    Dim First As Tasks
    Dim Second As Tasks
    Dim UniqueVal As String
    Dim Match(100000) As Boolean
    Dim Deletes(100000) As String
    Dim NumDeletes As Integer
    Dim Adds(100000) As String
    Dim NumAdds As Integer
    Dim Changes(100000) As Integer
    Dim UniqueIdentifier As String
    Dim OrigFile As String
    Dim NewFile As String
    Dim xlApp As Excel.Application
    Dim xlWorkBook As Excel.Workbook
    Dim XLSheet As Excel.Worksheet
    Dim oTask As Task
    Dim i As Long
    x = Application.Projects.Count
    If x <> 2 Then
    MsgBox "You must have two projects open to execute a comparison. You have " & x & " open at this time."
    Exit Sub
    Else
    OrigFile = Application.Projects(1).Path & "\" & Application.Projects(1).Name
    NewFile = Application.Projects(2).Path & "\" & Application.Projects(2).Name
    UniqueIdentifier = InputBox("Which field uniquely identifies tasks?", "Input Unique Identifier", "UniqueID")
    Set xlApp = CreateObject("Excel.Application", "")
    xlApp.Visible = False
    xlApp.Workbooks.Add
    Set xlWorkBook = xlApp.ActiveWorkbook
    Set XLSheet = xlApp.ActiveSheet
    xlApp.Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = "Comparison between project " & OrigFile & " (Project 1) and " & NewFile & " (Project 2)"
    xlApp.Range("A6").Select
    xlApp.ActiveCell.FormulaR1C1 = "Project"
    xlApp.Range("B6").Select
    xlApp.ActiveCell.FormulaR1C1 = "Task"
    xlApp.Range("C6").Select
    xlApp.ActiveCell.FormulaR1C1 = "Name"
    xlApp.Range("D6").Select
    xlApp.ActiveCell.FormulaR1C1 = "WBS"
    xlApp.Range("E6").Select
    xlApp.ActiveCell.FormulaR1C1 = "Duration"
    xlApp.Range("F6").Select
    xlApp.ActiveCell.FormulaR1C1 = "Preds"
    xlApp.Range("G6").Select
    xlApp.ActiveCell.FormulaR1C1 = "ES"
    xlApp.Range("H6").Select
    xlApp.ActiveCell.FormulaR1C1 = "EF"
    xlApp.Range("I6").Select
    xlApp.ActiveCell.FormulaR1C1 = "BaselineWork"
    xlApp.Range("J6").Select
    xlApp.ActiveCell.FormulaR1C1 = "BaselineCost"
    xlApp.Range("K6").Select
    xlApp.ActiveCell.FormulaR1C1 = "Work"
    xlApp.Range("L6").Select
    xlApp.ActiveCell.FormulaR1C1 = "Cost"
    xlApp.ActiveCell.Offset(1, -11).Range("A1").Select
    Set First = Application.Projects(1).Tasks
    Set Second = Application.Projects(2).Tasks
    Select Case UniqueIdentifier
    Case "UniqueID"
    For Each Task In First
    If Not (Task Is Nothing) Then
    UniqueVal = Trim(Task.UniqueID)
    xlApp.ActiveCell.FormulaR1C1 = "1"
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = UniqueVal
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Name
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.WBS
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = (Task.Duration / 480)
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Predecessors
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.EarlyStart
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.EarlyFinish
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.BaselineWork
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.BaselineCost
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Work
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Cost
    ' XLApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.Offset(1, -11).Range("A1").Select
    For Each oTask In Second
    If Not (oTask Is Nothing) Then
    If Trim(oTask.UniqueID) = UniqueVal Then
    xlApp.ActiveCell.FormulaR1C1 = "2"
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    Match(Task.UniqueID) = True
    xlApp.ActiveCell.FormulaR1C1 = oTask.UniqueID
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Name
    If oTask.Name <> Task.Name Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.WBS
    If oTask.WBS <> Task.WBS Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = (oTask.Duration / 480)
    If oTask.Duration <> Task.Duration Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Predecessors
    If oTask.Predecessors <> Task.Predecessors Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.EarlyStart
    If oTask.EarlyStart <> Task.EarlyStart Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.EarlyFinish
    If oTask.EarlyFinish <> Task.EarlyFinish Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.BaselineWork
    If oTask.BaselineWork <> Task.BaselineWork Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.BaselineCost
    If oTask.BaselineCost <> Task.BaselineCost Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Work
    If oTask.Work <> Task.Work Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Cost
    ' XLApp.ActiveCell.Offset(0, 1).Range("A1").Select
    If oTask.Cost <> Task.Cost Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(1, -11).Range("A1").Select
    End If
    End If
    Next
    If Not Match(Task.UniqueID) Then
    NumDeletes = NumDeletes + 1
    Deletes(NumDeletes) = Task.UniqueID
    End If
    End If
    Next
    For Each Task In Second
    If Not (Task Is Nothing) Then
    UniqueVal = Trim(Task.UniqueID)
    For Each oTask In First
    If Not (oTask Is Nothing) Then
    If Trim(oTask.UniqueID) = UniqueVal Then
    Match(Task.UniqueID) = True
    End If
    End If
    Next
    If Not Match(Task.UniqueID) Then
    NumAdds = NumAdds + 1
    Adds(NumAdds) = Task.UniqueID
    End If
    End If
    Next
    Case "Text1"
    For Each Task In First
    UniqueVal = Trim(Task.Text1)
    xlApp.ActiveCell.FormulaR1C1 = "1"
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = UniqueVal
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Name
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.WBS
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = (Task.Duration / 480)
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Predecessors
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.EarlyStart
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.EarlyFinish
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.LateStart
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.LateFinish
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.FreeSlack
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.TotalSlack
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.Offset(1, -12).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = "2"
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    For Each oTask In Second
    If Trim(oTask.Text1) = UniqueVal Then
    Match(Task.Text1) = True
    xlApp.ActiveCell.FormulaR1C1 = oTask.Text1
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Name
    If oTask.Name <> Task.Name Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.WBS
    If oTask.WBS <> Task.WBS Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = (oTask.Duration / 480)
    If oTask.Duration <> Task.Duration Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Predecessors
    If oTask.Predecessors <> Task.Predecessors Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.EarlyStart
    If oTask.EarlyStart <> Task.EarlyStart Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.EarlyFinish
    If oTask.EarlyFinish <> Task.EarlyFinish Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.LateStart
    If oTask.LateStart <> Task.LateStart Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.LateFinish
    If oTask.LateFinish <> Task.LateFinish Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.FreeSlack
    If oTask.FreeSlack <> Task.FreeSlack Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.TotalSlack
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    If oTask.TotalSlack <> Task.TotalSlack Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.Text1) = Changes(Task.Text1) + 1
    End If
    End If
    Next
    If Not Match(Task.Text1) Then
    NumDeletes = NumDeletes + 1
    Deletes(NumDeletes) = Task.Text1
    End If
    xlApp.ActiveCell.Offset(1, -12).Range("A1").Select
    Next
    For Each Task In Second
    UniqueVal = Trim(Task.Text1)
    For Each oTask In First
    If Trim(oTask.Text1) = UniqueVal Then
    Match(Task.Text1) = True
    End If
    Next
    If Not Match(Task.Text1) Then
    NumAdds = NumAdds + 1
    Adds(NumAdds) = Task.Text1
    End If
    Next
    Case "ID"
    For Each Task In First
    If Not (Task Is Nothing) Then
    UniqueVal = Trim(Task.UniqueID)
    xlApp.ActiveCell.FormulaR1C1 = "1"
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = UniqueVal
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Name
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.WBS
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = (Task.Duration / 480)
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Predecessors
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.EarlyStart
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.EarlyFinish
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.LateStart
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.LateFinish
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.FreeSlack
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.TotalSlack
    ' XLApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.Offset(1, -11).Range("A1").Select
    For Each oTask In Second
    If Not (oTask Is Nothing) Then
    If Trim(oTask.UniqueID) = UniqueVal Then
    xlApp.ActiveCell.FormulaR1C1 = "2"
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    Match(Task.UniqueID) = True
    xlApp.ActiveCell.FormulaR1C1 = oTask.UniqueID
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Name
    If oTask.Name <> Task.Name Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.WBS
    If oTask.WBS <> Task.WBS Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = (oTask.Duration / 480)
    If oTask.Duration <> Task.Duration Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Predecessors
    If oTask.Predecessors <> Task.Predecessors Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.EarlyStart
    If oTask.EarlyStart <> Task.EarlyStart Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.EarlyFinish
    If oTask.EarlyFinish <> Task.EarlyFinish Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.LateStart
    If oTask.LateStart <> Task.LateStart Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.LateFinish
    If oTask.LateFinish <> Task.LateFinish Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.FreeSlack
    If oTask.FreeSlack <> Task.FreeSlack Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.TotalSlack
    ' XLApp.ActiveCell.Offset(0, 1).Range("A1").Select
    If oTask.TotalSlack <> Task.TotalSlack Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.UniqueID) = Changes(Task.UniqueID) + 1
    End If
    xlApp.ActiveCell.Offset(1, -11).Range("A1").Select
    End If
    End If
    Next
    If Not Match(Task.UniqueID) Then
    NumDeletes = NumDeletes + 1
    Deletes(NumDeletes) = Task.UniqueID
    End If
    End If
    Next
    For Each Task In Second
    If Not (Task Is Nothing) Then
    UniqueVal = Trim(Task.UniqueID)
    For Each oTask In First
    If Not (oTask Is Nothing) Then
    If Trim(oTask.UniqueID) = UniqueVal Then
    Match(Task.UniqueID) = True
    End If
    End If
    Next
    If Not Match(Task.UniqueID) Then
    NumAdds = NumAdds + 1
    Adds(NumAdds) = Task.UniqueID
    End If
    End If
    Next
    Case "WBS"
    For Each Task In First
    UniqueVal = Trim(Task.WBS)
    xlApp.ActiveCell.FormulaR1C1 = "1"
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = UniqueVal
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Name
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.WBS
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = (Task.Duration / 480)
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.Predecessors
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.EarlyStart
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.EarlyFinish
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.LateStart
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.LateFinish
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.FreeSlack
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = Task.TotalSlack
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.Offset(1, -12).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = "2"
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    For Each oTask In Second
    If Trim(oTask.WBS) = UniqueVal Then
    Match(Task.WBS) = True
    xlApp.ActiveCell.FormulaR1C1 = oTask.WBS
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Name
    If oTask.Name <> Task.Name Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.WBS
    If oTask.WBS <> Task.WBS Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = (oTask.Duration / 480)
    If oTask.Duration <> Task.Duration Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.Predecessors
    If oTask.Predecessors <> Task.Predecessors Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.EarlyStart
    If oTask.EarlyStart <> Task.EarlyStart Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.EarlyFinish
    If oTask.EarlyFinish <> Task.EarlyFinish Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.LateStart
    If oTask.LateStart <> Task.LateStart Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.LateFinish
    If oTask.LateFinish <> Task.LateFinish Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.FreeSlack
    If oTask.FreeSlack <> Task.FreeSlack Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = oTask.TotalSlack
    xlApp.ActiveCell.Offset(0, 1).Range("A1").Select
    If oTask.TotalSlack <> Task.TotalSlack Then
    xlApp.ActiveCell.Select
    With xlApp.Selection.Font
    .FontStyle = "Bold"
    .ColorIndex = 46
    End With
    Changes(Task.WBS) = Changes(Task.WBS) + 1
    End If
    End If
    Next
    If Not Match(Task.WBS) Then
    NumDeletes = NumDeletes + 1
    Deletes(NumDeletes) = Task.WBS
    End If
    xlApp.ActiveCell.Offset(1, -12).Range("A1").Select
    Next
    For Each Task In Second
    UniqueVal = Trim(Task.WBS)
    For Each oTask In First
    If Trim(oTask.WBS) = UniqueVal Then
    Match(Task.WBS) = True
    End If
    Next
    If Not Match(Task.WBS) Then
    NumAdds = NumAdds + 1
    Adds(NumAdds) = Task.WBS
    End If
    Next
    End Select
    End If
    If NumAdds > 0 Then
    xlApp.ActiveCell.Offset(2, 1).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = "Tasks Added"
    xlApp.ActiveCell.Offset(1, 0).Range("A1").Select
    For i = 1 To NumAdds
    xlApp.ActiveCell.FormulaR1C1 = "Task " & Adds(i) & " was added."
    xlApp.ActiveCell.Offset(1, 0).Range("A1").Select
    Next i
    End If
    If NumDeletes > 0 Then
    xlApp.ActiveCell.Offset(2, 0).Range("A1").Select
    xlApp.ActiveCell.FormulaR1C1 = "Tasks Deleted"
    xlApp.ActiveCell.Offset(1, 0).Range("A1").Select
    For i = 1 To NumDeletes
    xlApp.ActiveCell.FormulaR1C1 = "Task " & Deletes(i) & " was deleted."
    xlApp.ActiveCell.Offset(1, 0).Range("A1").Select
    Next i
    End If
    Set First = Nothing
    Set Second = Nothing
    xlApp.Visible = True
    End Sub
    Last edited by Aussiebear; 02-19-2022 at 07:48 PM. Reason: Changed code tags

  2. #2
    VBAX Regular
    Joined
    Jun 2009
    Location
    Dorset
    Posts
    60
    Location
    Nice code - thank you.
    Regards
    JD
    ------------------------------------
    Software-Matters
    Dorset

  3. #3
    Comment = "Wow I'll have to look at that in more depth."
    Suggestion = "Use Trim$ instead of Trim, it runs faster."

    Seriously though, you should make this a KBase Entry. Do you know how to do that?
    Cordially,
    Aaron



    Keep Our Board Clean!
    • Please Mark your thread "Solved" if you get an acceptable response (under thread tools).
    • Enclose your code in VBA tags then it will be formatted as per the VBIDE to improve readability.

  4. #4
    I know this thread is quite dated, but I stumbled across the above macro and have brushed it up a little to run faster and. Thanks to the original author and my code is below (You need the Sub and the function).
    Hope this helps,
    Harald


    Sub Compare2ProjectFiles()
    Dim intPjCount As Integer
        Dim pj1 As Tasks
        Dim pj2 As Tasks
        Dim OrigFile As String
        Dim NewFile As String
        Dim xlApp As Excel.Application
        Dim xlBook As Excel.Workbook
        Dim xlSheet As Excel.Worksheet
        Dim rOut As Excel.Range
        Dim Cell As Excel.Range
        Dim intCount As Integer
        Dim blnIsDifferent As Boolean
    Dim strPath As String
        Dim strFileName As String
    Dim t1 As Task, t2 As Task
    Dim blnTaskMatch As Boolean
    Dim arrP1() As Variant
        Dim arrP2() As Variant
    intPjCount = Application.Projects.Count
        If intPjCount <> 2 Then
            MsgBox "You must have two projects open to execute a comparison. You have " & intPjCount & " open at this time."
            Exit Sub
        End If
    OrigFile = Application.Projects(1).Path & "" & Application.Projects(1).Name
        NewFile = Application.Projects(2).Path & "" & Application.Projects(2).Name
    Set pj1 = Application.Projects(1).Tasks
        Set pj2 = Application.Projects(2).Tasks
    'Open an empty Excel sheet
        Set xlApp = CreateObject("Excel.Application") 'New Excel.Application
    xlApp.Visible = False
        xlApp.Workbooks.Add
    Set xlBook = xlApp.ActiveWorkbook
        Set xlSheet = xlApp.ActiveSheet
    'Header
        With xlSheet
            .Range("A1") = "Comparison between two project files (P1 and P2)"
            .Rows("1:1").Style = "Heading 1"
            .Range("A2") = "Created on " & Format(Now(), "dd/mm/yyyy") & " by " & Environ("username")
    .Range("A4") = "P1: " & OrigFile
            .Range("A5") = "P2: " & NewFile
    Set rOut = .Range("A7").Resize(1, 13)
            rOut = Array("Project", "ID", "Task Name", "WBS", "Dur(d)", "Successors", "Predecessors", "Start", "Finish", "BaselineWork", "BaselineCost", "Work", "Cost")
            rOut.Font.Bold = True
    Set rOut = rOut.Offset(1, 0)
    For Each t1 In pj1
    Application.StatusBar = "Comparing task " & t1.ID: DoEvents
                'xlApp.StatusBar = "Processing task " & t1.ID: DoEvents
    'Write key data into an array
                arrP1() = AddTaskDataToArray(t1, "P1")
                blnTaskMatch = False
    For Each t2 In pj2
                    If t1.UniqueID = t2.UniqueID Then
                        arrP2 = AddTaskDataToArray(t2, "P2")
                        blnTaskMatch = True
                        Exit For
                    End If
                Next t2
    'Task of P1 not found in P2
                If blnTaskMatch = False Then
                    rOut.Resize(1, 1) = "Task deleted: " & t1.WBS & " - " & t1.Name
                    rOut.Interior.ColorIndex = 3
                    Set rOut = rOut.Offset(2, 0)
                    'Write out if different
                Else
                    blnIsDifferent = False
                    For intCount = LBound(arrP1) + 1 To UBound(arrP1)
                        If arrP1(intCount) <> arrP2(intCount) And intCount <> 3 Then 'Exclude the WBS number from the comparison
                            blnIsDifferent = True
                        End If
                    Next intCount
    If blnIsDifferent Then
                        rOut = arrP1
                        rOut.Offset(1, 0) = arrP2
    For Each Cell In rOut.Offset(0, 1)
                            If Cell <> Cell.Offset(1, 0) Then Cell.Offset(1, 0).Interior.ColorIndex = 6
                        Next Cell
    Set rOut = rOut.Offset(3, 0)
                    End If
    End If
    Next t1
    'Find added tasks
            blnTaskMatch = False
    For Each t2 In pj2
                Application.StatusBar = "Checking for added tasks " & t2.ID
                For Each t1 In pj1
                    If t1.UniqueID = t2.UniqueID Then
                        blnTaskMatch = True
                    End If
                Next t1
    If blnTaskMatch = False Then
                    rOut.Resize(1, 1) = "Task added: " & t2.WBS & " - " & t2.Name
                    rOut.Interior.ColorIndex = 4
                    Set rOut = rOut.Offset(2, 0)
                End If
    blnTaskMatch = False
    Next t2
    .Columns("A:L").AutoFit
            .Columns("A:B").ColumnWidth = 7
            .Columns("C:C").ColumnWidth = 50
            .Columns("F:G").ColumnWidth = 20
    End With
    Set pj1 = Nothing
        Set pj2 = Nothing
        Set xlSheet = Nothing
    Application.StatusBar = "Storing file on desktop ..."
    strPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & ""
        strFileName = Format(Now(), "yyyy-mm-dd hh-mm") & " Project file comparison"
        xlBook.SaveAs strPath & strFileName
    Application.StatusBar = False
    If MsgBox("All done, file saved to desktop as " & vbCrLf & strFileName & vbCrLf & "Do you want to open it now?", vbYesNo) = vbYes Then
            xlApp.Quit
            Set xlApp = Nothing
            Application.StatusBar = False
            CreateObject("Shell.Application").Open (strPath & strFileName & ".xlsx")
        End If
    End Sub
    
    Function AddTaskDataToArray(t As Task, strProjectID As String) As Variant()
    Dim arrResult(0 To 12) As Variant
    arrResult(0) = strProjectID
        arrResult(1) = t.ID
        arrResult(2) = t.Name
        arrResult(3) = t.WBS
        arrResult(4) = t.Duration / 480
        arrResult(5) = CStr(t.Successors)
        arrResult(6) = CStr(t.Predecessors)
        arrResult(7) = t.Start
        arrResult(8) = t.Finish
        arrResult(9) = t.BaselineWork
        arrResult(10) = t.BaselineCost
        arrResult(11) = t.Work
        arrResult(12) = t.Cost
    AddTaskDataToArray = arrResult
    End Function
    Last edited by Aussiebear; 02-15-2022 at 01:12 PM. Reason: Added code tags to supplied code

  5. #5
    VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,709
    Location
    HDeinHammer, you, too, should look into our KB submissions
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •