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
").HorizontalAlignment = xlHAlignLeft '
Activity Name
.ActiveSheet.Columns("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