Compare two versions of a Project file

[HDeinhammer]

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