Slow exports from MS Project to Excel

B

Brenda

Hello,

I have a number of macros in MS Project that export data from MS Project to
Excel. These have worked great up until upgrading Excel. My old
configuration was MS Project 2007 and MS Excel 2003. Since upgrading to MS
Excel 2007 it takes considerably longer to run the macros. Additionally, a
coworker who was already on MS Excel 2007 but recently upgraded to MS Project
2007 (though they never used the macros prior to Project 2007) is finding
them to be exceptionally slow as well. Unfortunately, I have no ability to
give any metrics on how long it took prior to the upgrade and how long it is
taking now, but it is a considerable difference. Has anyone else experienced
this and if so, is there a solution? I've done some searches and have found
nothing so far. Let me know if it is critical to see an example of one of
the macros to troubleshoot this.

Thanks!
 
B

Brenda

I did find some posts on this board about Excel 2007 macros being much slower
than in 2003, so I suspect that I'm experiencing the same issue as others
even though my macro is actually running in MS Project. It sounds like the
only way anyone might be able to help is by viewing the code. Below is one
of the macros that we are using. This was written by someone else and I have
just made tweaks to it. I'm definitely not a VBA developer!

Thanks again!

Sub AllTaskstoExcel()
'===========================================
' This macro exports all project tasks to a single Excel worksheet tab.
'===========================================

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range
Dim Proj As Project
Dim T As Task
Dim ts As Tasks

Dim Asgn As Assignment
Dim ColumnCount As Integer
Dim Columns As Integer
Dim Tcount As Integer
Dim calcFinishDAte As Variant
Dim myStartDate As Date
Dim ProjName As String

If xlApp Is Nothing Then
'Start new instance
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't Find Excel, please try again.", vbCritical
End 'Stop, can't proceed without Excel
End If
Else
Set xlR = Nothing
Set xlApp = Nothing
Set xlBook = Nothing
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't Find Excel, please try again.", vbCritical
End 'Stop, can't proceed without Excel
End If
End If

Set xlBook = xlApp.Workbooks.Add

AppActivate "Microsoft Project"
xlApp.Visible = True
AppActivate "Microsoft Excel"

'Get the Project Name to be used in the Page Header
'You need to change the project name in the "GetProjectName" macro/module
ProjName = MyProjName()

Set xlSheet = xlBook.Worksheets.Add
xlSheet.Name = "All Tasks for Team" ' Description for the Excel
worksheet tab
xlSheet.PageSetup.CenterHeader = "&B &14" + ProjName + "&B" ' Makes the
header you entered bold and 14 pt font size
xlSheet.PageSetup.RightMargin = 25
xlSheet.PageSetup.LeftMargin = 25
xlSheet.PageSetup.TopMargin = 50
xlSheet.PageSetup.BottomMargin = 50
xlSheet.PageSetup.HeaderMargin = 25
xlSheet.PageSetup.FooterMargin = 25
xlSheet.PageSetup.RightFooter = "&09 Page &P of &N" ' Sets the right
footer to 9 pt font size and to say "Page x of x"
xlSheet.PageSetup.LeftFooter = "&09 &D &T" ' Sets the left footer to 9
pt font size and the current date/time
xlSheet.PageSetup.Orientation = xlLandscape ' Sets the Excel doc to
landscape
xlSheet.PageSetup.PaperSize = xlPaperLegal ' Sets the paper size to legal
xlSheet.PageSetup.Zoom = False ' This needs to be set to false for the
following setting to work properly
xlSheet.PageSetup.FitToPagesWide = 1 ' Sets the Excel doc to always
fit to one page wide
xlSheet.PageSetup.FitToPagesTall = 100 ' Sets the Excel doc to go up to
100 pages in length, if you think you will have a longer doc, change this #
xlSheet.PageSetup.PrintTitleRows = xlSheet.Rows(1).Address ' Repeats
the column headings on every page
xlSheet.Cells.VerticalAlignment = xlVAlignTop ' Aligns the text in the
cells to the top of the cell, this is good for when some columns wrap
xlSheet.PageSetup.PrintGridlines = True ' Prints gridlines, this is
helpful because borders will not fill in on blank resources cells
xlApp.ActiveWindow.GridlineColorIndex = 1 ' Sets the gridline color to a
dark color

Do While xlBook.Worksheets.Count > 1 ' This deletes extra blank tabs
xlBook.Worksheets(2).Delete
Loop

'count columns needed
ColumnCount = 1

'Set Range to write to first cell
Set xlRow = xlApp.ActiveCell

Set xlCol = xlRow.Offset(0, 0)
xlCol = "ID"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 4
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "SubTeam"
xlCol.Font.Bold = True
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "% Comp"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 6
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Activity"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 50
xlCol.WrapText = True
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Duration"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 5
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Start Date"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 12
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Finish Date"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 12
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Predecessors"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 7
xlCol.WrapText = True
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Act Start"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 10
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Act Finish"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 10
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Comments"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 50
xlCol.WrapText = True
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Resources"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 13
xlCol.VerticalAlignment = xlVAlignBottom

Tcount = 0

For Each T In ActiveProject.Tasks

myStartDate = DateFormat(T.Start, pjDate_mm_dd_yyyy)

'Set the fields
'Task ID
Set xlRow = xlRow.Offset(1, 0)
Set xlCol = xlRow.Offset(0, 0)

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If
xlCol = T.ID

'Subteam
Set xlCol = xlCol.Offset(0, 1)

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If
xlSheet.Columns("B").AutoFit ' Sizes column to fit longest
subteam name (or column heading if it is longest)
xlCol = T.Text30

'% Complete
Set xlCol = xlCol.Offset(0, 1)
xlCol = FormatPercent(T.PercentComplete / 100, 0)

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If

'Task Name
Set xlCol = xlCol.Offset(0, 1)
xlCol = T.Name
xlCol.WrapText = 1

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If
xlCol.IndentLevel = T.OutlineLevel

'Duration
Set xlCol = xlCol.Offset(0, 1)
xlCol = T.Duration / 480
xlCol.WrapText = 1

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If

'Start Date
Set xlCol = xlCol.Offset(0, 1)
xlCol.HorizontalAlignment = xlHAlignRight

If DateFormat(T.Start, pjDate_mm_dd_yy) = "1/1/2010" Then
xlCol = ""
Else
xlCol = DateFormat(T.Start, pjDate_ddd_mm_dd_yy)
End If

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If

'Finish Date
Set xlCol = xlCol.Offset(0, 1)
xlCol.HorizontalAlignment = xlHAlignRight

If T.BaselineFinish = "NA" Then
calcFinishDAte = T.Finish
Else
calcFinishDAte = T.BaselineFinish
End If
If DateFormat(calcFinishDAte, pjDate_mm_dd_yy) = "1/1/2010" Then
xlCol = ""
Else
xlCol = DateFormat(T.Finish, pjDate_ddd_mm_dd_yy)
End If

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If

'Predecessors
Set xlCol = xlCol.Offset(0, 1)
xlCol = T.Predecessors
xlCol.WrapText = 1

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If

'Actual Start
Set xlCol = xlCol.Offset(0, 1)
If T.ActualStart = "NA" Then
xlCol = ""
Else
xlCol = DateFormat(T.ActualStart, pjDate_mm_dd_yy)
End If

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If

'Actual Finish
Set xlCol = xlCol.Offset(0, 1)
If T.ActualFinish = "NA" Then
xlCol = ""
Else
xlCol = DateFormat(T.ActualFinish, pjDate_mm_dd_yy)
End If

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If

'Notes/Comments
Set xlCol = xlCol.Offset(0, 1)
xlCol = T.Notes
xlCol.WrapText = 1

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If


'Resources
For Each Asgn In T.Assignments
Set xlCol = xlCol.Offset(0, 1)
xlCol = Asgn.Resourcename

'Set Font Color/Style based on if summary level as well as
%complete and Finish date information
If T.Summary Then 'If this is a summary level task, make it
bold and black
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 1
ElseIf T.PercentComplete = 100 Then
xlCol.Font.ColorIndex = 1 'Black = Completed tasks
ElseIf T.Finish < Date And T.PercentComplete < 100 Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 3 'Red/Bold = Overdue tasks
ElseIf myStartDate <= Date And T.PercentComplete = 0 And
T.ActualStart = "NA" Then
xlCol.Font.Bold = True
xlCol.Font.ColorIndex = 45 'Orange/Bold = Tasks that should
have started but haven't
ElseIf T.Finish >= Date And ((T.PercentComplete > 0 And
T.PercentComplete < 100) _
Or (T.ActualStart <> "NA" And T.ActualFinish = "NA")) Then
xlCol.Font.ColorIndex = 10 'Green = Tasks that are In Progress
Else
xlCol.Font.ColorIndex = 5 'Blue = Tasks that are upcoming
End If

'Size the Resource columns to fit contents - going to Z allows a
number of resources per task. If you need more columns
'for resources, change the Z to the appropriate column identifier.
xlSheet.Columns("K:Z").AutoFit

Next Asgn

getnext:
Next
AppActivate "Microsoft Project"

'Freezes at the row with column headers then sets the focus back to the
first cell in the sheet
xlApp.Rows("2:2").Select
xlApp.ActiveWindow.FreezePanes = True
xlApp.Range("a1:a1").Select

xlApp.Visible = True

End Sub
 
E

EricG

I modified your code a little. This version should speed things up
considerably. It does two things. First, it uses
"Application.ScreenUpdating" to turn off/on Excel screen updating. Any time
you do things like formatting cells, it slows Excel down a bunch. Second, I
first pull all the task information into memory to manipulate it in one big
array, and the place the entire contents of the array onto the Excel
worksheet. That's quicker than doing things cell-by-cell. Finally, I do
some of the formatting on entire columns or rows, again better than the
cell-by-cell approach. Try it and feed back your results. It sped up my
small test project by a factor of three. If it works, you can use the code
as an example of what you can do to all of your macros to speed them up.

HTH,

Eric

Option Explicit
Option Base 1

Sub AllTaskstoExcel()
'===========================================
' This macro exports all project tasks to a single Excel worksheet tab.
'===========================================

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range
Dim Proj As Project
Dim T As Task
Dim ts As Tasks
Dim time1 As Double

Dim Asgn As Assignment
Dim Columns As Integer
Dim calcFinishDAte As Variant
Dim myStartDate As Date
Dim ProjName As String

If xlApp Is Nothing Then
'Start new instance
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't Find Excel, please try again.", vbCritical
End 'Stop, can't proceed without Excel
End If
Else
Set xlRow = Nothing
Set xlCol = Nothing
Set xlApp = Nothing
Set xlBook = Nothing
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't Find Excel, please try again.", vbCritical
End 'Stop, can't proceed without Excel
End If
End If

xlApp.ScreenUpdating = False
time1 = Timer()

Set xlBook = xlApp.Workbooks.Add

AppActivate "Microsoft Project"
xlApp.Visible = True
AppActivate "Microsoft Excel"

'Get the Project Name to be used in the Page Header
'You need to change the project name in the "GetProjectName" macro/module
'#######################################
' NOTE: I changed the following line!
'#######################################
ProjName = ThisProject.Name

Set xlSheet = xlBook.Worksheets.Add
With xlSheet
.Name = "All Tasks for Team" ' Description for the Excel worksheet tab
.PageSetup.CenterHeader = "&B &14" + ProjName + "&B" ' Makes the header
you entered bold and 14 pt font size
.PageSetup.RightMargin = 25
.PageSetup.LeftMargin = 25
.PageSetup.TopMargin = 50
.PageSetup.BottomMargin = 50
.PageSetup.HeaderMargin = 25
.PageSetup.FooterMargin = 25
.PageSetup.RightFooter = "&09 Page &P of &N" ' Sets the right footer to
9 pt font size and to say "Page x of x"
.PageSetup.LeftFooter = "&09 &D &T" ' Sets the left footer to 9 pt font
size and the current date/time
.PageSetup.Orientation = xlLandscape ' Sets the Excel doc to landscape
.PageSetup.PaperSize = xlPaperLegal ' Sets the paper size to legal
.PageSetup.Zoom = False ' This needs to be set to false for the
following setting to work properly
.PageSetup.FitToPagesWide = 1 ' Sets the Excel doc to always fit to
one page wide
.PageSetup.FitToPagesTall = 100 ' Sets the Excel doc to go up to 100
pages in length, if you think you will have a longer doc, change this #
.PageSetup.PrintTitleRows = .Rows(1).Address ' Repeats the column
headings on every page
.Cells.VerticalAlignment = xlVAlignTop ' Aligns the text in the cells
to the top of the cell, this is good for when some columns wrap
.PageSetup.PrintGridlines = True ' Prints gridlines, this is helpful
because borders will not fill in on blank resources cells
End With

xlApp.ActiveWindow.GridlineColorIndex = 1 ' Sets the gridline color to a
dark Color

Do While xlBook.Worksheets.Count > 1 ' This deletes extra blank tabs
xlBook.Worksheets(2).Delete
Loop

'Set Range to write to first cell
xlApp.Cells(1, 1).Select
Set xlRow = xlApp.ActiveCell

Set xlCol = xlRow.Offset(0, 0)
xlCol = "ID"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 4
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "SubTeam"
xlCol.Font.Bold = True
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "% Comp"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 6
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Activity"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 50
xlCol.WrapText = True
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Duration"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 5
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Start Date"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 12
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Finish Date"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 12
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Predecessors"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 7
xlCol.WrapText = True
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Act Start"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 10
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Act Finish"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 10
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Comments"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 50
xlCol.WrapText = True
xlCol.VerticalAlignment = xlVAlignBottom

Set xlCol = xlCol.Offset(0, 1)
xlCol = "Resources"
xlCol.Font.Bold = True
xlCol.ColumnWidth = 13
xlCol.VerticalAlignment = xlVAlignBottom

'
' First suck the entire project into memory.
'
Dim tData() As Variant
Dim projData() As Variant
Dim resData() As Variant
Dim nTasks As Long, i As Long, j As Long
Dim nAssgn As Long, maxAssgn As Long
'
nTasks = ActiveProject.Tasks.Count
ReDim tData(nTasks, 4)
ReDim projData(nTasks, 11) ' Stores everything EXCEPT resource data for
each task
ReDim resData(nTasks, 1) ' Stores resource data for each task.
'
For i = 1 To nTasks
' Summary
tData(i, 1) = ActiveProject.Tasks(i).Summary '******
' Count of Resources
tData(i, 2) = ActiveProject.Tasks(i).Assignments.Count
' Outline Level
tData(i, 3) = ActiveProject.Tasks(i).OutlineLevel
' "myStartDate"
tData(i, 4) = DateFormat(ActiveProject.Tasks(i).Start, pjDate_mm_dd_yyyy)
' ID
projData(i, 1) = ActiveProject.Tasks(i).ID
' Subteam
projData(i, 2) = ActiveProject.Tasks(i).Text30
' % Complete
projData(i, 3) = ActiveProject.Tasks(i).PercentComplete / 100#
' Name
projData(i, 4) = ActiveProject.Tasks(i).Name
' Duration
projData(i, 5) = ActiveProject.Tasks(i).Duration / 480#
' Start
If (DateFormat(ActiveProject.Tasks(i).Start, pjDate_mm_dd_yy) =
"1/1/2010") Then
projData(i, 6) = ""
Else
projData(i, 6) = ActiveProject.Tasks(i).Start
End If
' Finish
If (ActiveProject.Tasks(i).BaselineFinish = "NA") Then
calcFinishDAte = ActiveProject.Tasks(i).Finish
Else
calcFinishDAte = ActiveProject.Tasks(i).BaselineFinish
End If
If (DateFormat(calcFinishDAte, pjDate_mm_dd_yy) = "1/1/2010") Then
projData(i, 7) = ""
Else
projData(i, 7) = ActiveProject.Tasks(i).Finish
End If
' Predecessors
projData(i, 8) = ActiveProject.Tasks(i).Predecessors
' Actual Start
If (ActiveProject.Tasks(i).ActualStart = "NA") Then
projData(i, 9) = ""
Else
projData(i, 9) = ActiveProject.Tasks(i).ActualStart
End If
' Actual Finish
If (ActiveProject.Tasks(i).ActualFinish = "NA") Then
projData(i, 10) = ""
Else
projData(i, 10) = ActiveProject.Tasks(i).ActualFinish
End If
' Notes
projData(i, 11) = ActiveProject.Tasks(i).Notes
' Resources
nAssgn = ActiveProject.Tasks(i).Assignments.Count
If (nAssgn > maxAssgn) Then
maxAssgn = nAssgn
ReDim Preserve resData(nTasks, maxAssgn)
End If
For j = 1 To nAssgn
resData(i, j) = ActiveProject.Tasks(i).Assignments(j).ResourceName
Next j
Next i
'
' Next, blast the stuff in memory onto the worksheet.
'
xlApp.Range(xlApp.ActiveSheet.Cells(2, 1), xlApp.ActiveSheet.Cells(2 +
nTasks - 1, 11)).Select
xlApp.Selection = projData
If (maxAssgn > 0) Then
xlApp.Range(xlApp.ActiveSheet.Cells(2, 12),
xlApp.ActiveSheet.Cells(2 + nTasks - 1, 12 + maxAssgn - 1)).Select
xlApp.Selection = resData
End If
'
' Finally, format the resulting data on the worksheet
'
' Columns first...
'
With xlApp
.ActiveSheet.Columns("A:A").HorizontalAlignment = xlHAlignCenter '
ID
.ActiveSheet.Columns("A:A").AutoFit
.ActiveSheet.Columns("B:B").HorizontalAlignment = xlHAlignLeft '
SubTeam
.ActiveSheet.Columns("B:B").AutoFit
.ActiveSheet.Columns("C:C").HorizontalAlignment = xlHAlignLeft '
%Complete
.ActiveSheet.Columns("C:C").NumberFormat = "0%"
.ActiveSheet.Columns("C:C").AutoFit
.ActiveSheet.Columns("D:D").HorizontalAlignment = xlHAlignLeft '
Activity Name
.ActiveSheet.Columns("D:D").WrapText = True
.ActiveSheet.Columns("E:E").HorizontalAlignment = xlHAlignCenter '
ID
.ActiveSheet.Columns("E:E").AutoFit
.ActiveSheet.Columns("F:G").HorizontalAlignment = xlHAlignLeft '
Dates
.ActiveSheet.Columns("F:G").NumberFormat = "m/d/yyyy;@"
.ActiveSheet.Columns("H:H").HorizontalAlignment = xlHAlignCenter '
Predecessors
.ActiveSheet.Columns("H:H").WrapText = True
.ActiveSheet.Columns("I:J").HorizontalAlignment = xlHAlignLeft '
Dates
.ActiveSheet.Columns("I:J").NumberFormat = "m/d/yyyy;@"
.ActiveSheet.Columns("H:H").AutoFit
.ActiveSheet.Columns("K:K").HorizontalAlignment = xlHAlignLeft '
Comments
.ActiveSheet.Columns("K:K").WrapText = True
End With
'
' Now format row-by-row
'
With xlApp
For i = 1 To nTasks
If tData(i, 1) Then 'If this is a summary level task, make it
bold and black
.ActiveSheet.Rows(i + 1).Font.Bold = True
.ActiveSheet.Rows(i + 1).Font.ColorIndex = 1
ElseIf Abs(projData(i, 3) - 1#) < 0.001 Then
.ActiveSheet.Rows(i + 1).ColorIndex = 1
ElseIf projData(i, 7) < Date And Abs(projData(i, 3) - 1#) >
0.001 Then
.ActiveSheet.Rows(i + 1).Font.Bold = True
.ActiveSheet.Rows(i + 1).Font.ColorIndex = 3 'Red/Bold =
Overdue tasks
ElseIf tData(i, 4) <= Date And projData(i, 3) > 0.001 = 0 And
projData(i, 9) = "" Then
.ActiveSheet.Rows(i + 1).Font.Bold = True
.ActiveSheet.Rows(i + 1).Font.ColorIndex = 45
'Orange/Bold = Tasks that should have started but haven't
ElseIf (projData(i, 7) >= Date And (projData(i, 3) > 0.001 And
projData(i, 3) < 100) _
Or (projData(i, 9) <> "" And projData(i, 10) = "")) Then
.ActiveSheet.Rows(i + 1).Font.ColorIndex = 10 'Green =
Tasks that are In Progress
Else
.ActiveSheet.Rows(i + 1).Font.ColorIndex = 5 'Blue =
Tasks that are upcoming
End If
If (tData(i, 3) > 0) Then
.ActiveSheet.Cells(i + 1, 4).IndentLevel = tData(i, 3) - 1
End If
Next i
End With
'
AppActivate "Microsoft Project"

'Freezes at the row with column headers then sets the focus back to the
first cell in the sheet
xlApp.Rows("2:2").Select
xlApp.ActiveWindow.FreezePanes = True
xlApp.Range("a1:a1").Select

xlApp.ScreenUpdating = True

xlApp.Visible = True
MsgBox "Total time spent = " & Timer() - time1

End Sub
 
B

Brenda

WOW!! Eric, this was incredibly fast compared to what it was doing with my
code. Your code is also much more elegant than what had been done before. I
know enough to know that the way it had been written wasn't pretty, but it as
functional all the way up until working in Excel 2007. Your changes have
greatly improved the performance. The one thing that I and team members
using these will need to get used to is not seeing it being drawn on the
screen before our eyes. Once we are assured that it is actually working, I
think we will be very pleased with the results. Thanks so much for your
assistance!

Brenda
 
J

Just Another Yahoo!

Eric,
Nice work but I would recommend decreasing the WITH group dot parsing by
using:
WITH xlSheet.PageSetup
.RightMargin = 25
.LeftMargin = 25
....
END WITH
instead of what you currently used. The two lines that don't have
..PageSetup could be put in their own With grouping or just left as
individual statements e.g. xlSheet.Name = "All Tasks for Team". I read in
an Excel book for professionals (sorry MVPs, I don't remember the three
authors as the book is at home) that this can help save processing time.

Others,
To specifically illuminate what Eric is referring to about screen updating:
xlApp.ScreenUpdating = False
This turns off the screen so you won't see it update as the code goes along.
This can really help speed up code execution.

xlApp.ScreenUpdating = True
This will turn on the screen updating. If code is running and modifying
stuff on your worksheet then you will see it get updated. Typically the
screen will blink when code is running and screen updating is on.

I've heard the argument from some coders (but not end users!) that they
don't like to turn off screen updating because then the user knows Excel is
"working". I disagree and point to a more elegant "Excel is working"
method:
Application.StatusBar = "Hey, Excel is working so please wait..."
or whatever text you wish to use:
sMessage = "Working on file " & sFileName
Application.StatusBar = sMessage
and when you're done you can return the status bar back to normal:
Application.StatusBar = False

Naturally, if you want to get more whiz-bang, you can use a form to display
messages. I don't often cuz that's more work & things to go wrong, no fun
to debug for others, etc.
 
J

JP

In addition to what Eric and Toby suggested, you can shorten the code
even further. The entire upper- mid-section (the part that starts "Set
Range to write to first cell ") can be replaced with

Dim headerValues As Variant
Dim rngCount As Long
Dim rngHeader As Excel.Range

headerValues = Array("ID", "SubTeam", "% Comp", "Activity",
"Duration", "Start Date", _
"Finish Date", "Predecessors", "Act Start", "Act Finish",
"Comments", "Resources")

rngCount = UBound(headerValues) + 1

Set rngHeader = xlApp.Range(Range("A1"), Range("A" & rngCount))

rngHeader.Value = headerValues

With rngHeader
.Font.Bold = True
.VerticalAlignment = xlVAlignBottom
End With


--JP
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

object library problem 2
Cannot display Add-in Macro list without going to VBA/Project 5
Excel and MS Project 2
Converting Excel files to MS Project 2
has Excel software updates disabled VBA functions? 2
Ms Project to Excel Linked 3
Just switched to Excel 2007 from 2003 - Unclear how to enable macros 2
set PageSetup.PrintArea from MS Project 1

Top