Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Slow exports from MS Project to Excel
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! |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Slow exports from MS Project to Excel
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 "Brenda" wrote: 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! |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Slow exports from MS Project to Excel
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Slow exports from MS Project to Excel
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 "EricG" wrote: 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 ' |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Slow exports from MS Project to Excel
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. -- Toby Erkson Excel 2003, WinXP "EricG" wrote in message ... 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Slow exports from MS Project to Excel
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 On Sep 25, 4:28*pm, Brenda wrote: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Quickbooks exports to Excel, cleaning up the mess afterwards | Excel Worksheet Functions | |||
application exports number to excels text....can't format | Excel Discussion (Misc queries) | |||
application exports number to excels text....can't format | Excel Discussion (Misc queries) | |||
how can i exports or save picture out of excel worksheet | Excel Programming | |||
XML exports and style sheets | Excel Programming |