Here is an MS Project to VB Compiler if anyone wants it.

[mgoold2002]

Hi. This is code I use to compile a folder full of MS Project docs
into a single Excel Spreadsheet. For it to work, you should only have
MSP docs in the folder.

Good luck.
..........................................................................





Dim fso As New FileSystemObject
Dim k
Dim f As Folder
Dim objProj1 As MSProject.Project
Dim objTasks1
Dim intTaskscount As Integer
Dim intTaskscounter1 As Integer
Dim intTaskscounter2 As Integer
Dim objTask1
Dim aryTemparray
Dim strFilename As String
Dim strProduct1 As String
Dim strPORnum1 As String
Dim strProjDescr As String
Dim objSplitfilename


Sub compile_projects()

Set f = fso.GetFolder("C:\Documents and Settings\mgoold\Desktop
\DATA QC PROJECTS\Project Compiler")

inSheetctr = 1

ThisWorkbook.Sheets("CurrentCompile").Cells.Select
Selection.ClearContents

For Each File In f.Files

strFilename = File.Name
objSplitfilename = Split(strFilename, "--")
strProduct1 = objSplitfilename(0)
strPORnum1 = CStr(objSplitfilename(1))
strProjDescr = Replace(objSplitfilename(2), ".mpp", "")

k = File.Path

MSProject.FileOpen k, , , , , , True

Set objProj1 = MSProject.ActiveProject

intTaskscount = MSProject.ActiveProject.Tasks.Count

ReDim aryTemparray(intTaskscount - 1, 8)

intTaskscounter1 = 0

For Each Task In objProj1.Tasks

aryTemparray(intTaskscounter1, 0) = intTaskscounter1 + 1
aryTemparray(intTaskscounter1, 1) =
objProj1.Tasks(intTaskscounter1 + 1).Name
aryTemparray(intTaskscounter1, 2) =
objProj1.Tasks(intTaskscounter1 + 1).OutlineLevel
aryTemparray(intTaskscounter1, 3) =
objProj1.Tasks(intTaskscounter1 + 1).Start
aryTemparray(intTaskscounter1, 4) =
objProj1.Tasks(intTaskscounter1 + 1).Finish
aryTemparray(intTaskscounter1, 5) =
objProj1.Tasks(intTaskscounter1 + 1).Predecessors
aryTemparray(intTaskscounter1, 6) =
objProj1.Tasks(intTaskscounter1 + 1).ResourceNames
aryTemparray(intTaskscounter1, 7) =
objProj1.Tasks(intTaskscounter1 + 1).PercentWorkComplete
aryTemparray(intTaskscounter1, 8) =
objProj1.Tasks(intTaskscounter1 + 1).UniqueID


intTaskscounter1 = intTaskscounter1 + 1

Next

Sheets("CurrentCompile").Activate
' Sheets.Add 0, 1, inSheetctr

Cells(2, 1).Select

For intTaskscounter1 = 0 To UBound(aryTemparray, 1)
intPlaceholder2 = intPlaceholder + intTaskscounter1
Cells(intPlaceholder2 + 2, 1) = strProduct1
Cells(intPlaceholder2 + 2, 2) = strPORnum1
Cells(intPlaceholder2 + 2, 3) = strProjDescr

For intTaskscounter2 = 0 To UBound(aryTemparray, 2)
Cells(intPlaceholder2 + 2, intTaskscounter2 + 4) =
aryTemparray(intTaskscounter1, intTaskscounter2)
Next
Next intTaskscounter1

' inSheetctr = inSheetctr + 1

intPlaceholder = intPlaceholder + intTaskscounter1

Next

MSProject.FileClose False, True

MSProject.Quit

DoFormatting
doindenting

Columns("F:F").Select
Selection.Delete Shift:=xlToLeft

End Sub

Sub DoFormatting()

Range("B:B,D").Select
Range("D1").Activate
Selection.NumberFormat = "0"
Range("F:F").Select
Range("F1").Activate
Selection.NumberFormat = "0"
Columns("G:H").Select
Range("H1").Activate
Selection.NumberFormat = "m/d/yyyy"
ActiveWorkbook.Save
Range("A1").Select
ActiveCell.FormulaR1C1 = "Product"
Range("B1").Select
ActiveCell.FormulaR1C1 = "POR"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Description"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Index"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Task Description"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Outline Level"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Start Date"
Range("H1").Select
ActiveCell.FormulaR1C1 = "End Date"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Precedence"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Task Owner"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Percent Complete"
Rows("1:1").Select
Selection.Font.Bold = True
End Sub

Sub doindenting()

Dim intColctr1 As Integer
Dim intColctr2 As Integer

Dim intRowctr1 As Integer

Dim intIndentctr As Integer
Dim intIndentctr2 As Integer

intColctr1 = 1
intColctr2 = 1

Do

If InStr(Trim(UCase(Cells(1, intColctr1))), Trim(UCase("Outline
Level"))) > 0 Then
Exit Do
End If
intColctr1 = intColctr1 + 1

Loop Until IsEmpty(Cells(1, intColctr1)) = True

Do

If InStr(Trim(UCase(Cells(1, intColctr2))), Trim(UCase("Task
Description"))) > 0 Then
Exit Do
End If
intColctr2 = intColctr2 + 1

Loop Until IsEmpty(Cells(1, intColctr2)) = True

intRowctr1 = 2

Do
If Cells(intRowctr1, intColctr1) = 1 Then
Cells(intRowctr1, intColctr2).Select
Selection.Font.Bold = True
ElseIf Cells(intRowctr1, intColctr1) > 1 Then
intIndentctr = CInt(Cells(intRowctr1, intColctr1))
Cells(intRowctr1, intColctr2).IndentLevel = 0
Cells(intRowctr1, intColctr2).InsertIndent
intIndentctr
End If
intRowctr1 = intRowctr1 + 1
Loop Until IsEmpty(Cells(intRowctr1, 1)) = True

End Sub