Try using this macro.
Public Sub ExcelSchedule()
'Creates a new table within the Task Sheet view (so it'll use the Task Sheet formatting), copies all data and pastes it into an Excel sheet.
'Within Excel, a table is created with slicers.
Dim i As Integer
'Sniff Test
'Is the Excel Library enabled?
For i = 1 To ActiveProject.VBProject.references.Count
If ActiveProject.VBProject.references.Item(i).Name = "Excel" Then
GoTo LibraryFound 'found library, continue
End If
Next i
'The Excel library was not found
MsgBox "This macro requires the Excel Library to run." & vbNewLine & _
"Take a screenshot of these instructions and click OK." & vbNewLine & vbNewLine & _
"In MS Project, press ""Alt + F11"" to open the VBA Editor." & vbNewLine & _
"Go to Tools >> References." & vbNewLine & _
"Place a checkmark next to ""Microsoft Excel 15.0 Object Library"". Notice it is Excel and not Office." & vbNewLine & _
"Click OK and run the macro again." _
, vbCritical, "Oops! Missing Library"
End
LibraryFound: 'continue with macro
ExcelSchedule_exe
End Sub
Private Sub ExcelSchedule_exe()
'Variables
Dim projectName As String
Dim xlRange As Excel.Range
Dim instrNotes As String
'Prepare
On Error GoTo ErrorHandler
UpdatesOFF
SaveOriginalSettings
WindowActivate TopPane:=True
ViewApply Name:="Task Sheet"
GroupApply Name:="No Group"
FilterApply Name:="All Tasks"
OutlineShowAllTasks
'Create Table in the Task Sheet View
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, Create:=True, OverwriteExisting:=True, FieldName:="ID", Title:="", Width:=6, Align:=1, ShowInMenu:=False, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, HeaderTextWrap:=False, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="ID", Title:="", Width:=7, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Predecessors", Title:="", Width:=7, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Successors", Title:="", Width:=7, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="% Complete", Title:="", Width:=7, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, HeaderTextWrap:=False, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Name", Title:="", Width:=50, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=True
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Resource Names", Title:="", Width:=18, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Status", Title:="", Width:=14, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, HeaderTextWrap:=False, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Work", Title:="", Width:=13, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Duration", Title:="", Width:=10, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Remaining Work", Title:="", Width:=15, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Start", Title:="", Width:=15, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Finish", Title:="", Width:=15, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Deadline", Title:="", Width:=14, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Baseline Start", Title:="", Width:=16, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Baseline Finish", Title:="", Width:=16, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Actual Start", Title:="", Width:=14, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Actual Finish", Title:="", Width:=14, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Start Variance", Title:="", Width:=14, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Finish Variance", Title:="", Width:=14, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Outline Level", Title:="", Width:=14, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Summary", Title:="", Width:=11, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, HeaderTextWrap:=False, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Active", Title:="", Width:=11, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Milestone", Title:="", Width:=11, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Critical", Title:="", Width:=10, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Number10", Title:="", Width:=13, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Text10", Title:="", Width:=13, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False
TableEditEx Name:="Excel Report - Good + Fast", TaskTable:=True, NewFieldName:="Notes", Title:="", Width:=32, Align:=0, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=0, WrapText:=False, ShowAddNewColumn:=True
TableApply Name:="Excel Report - Good + Fast"
'Create Remaining Work column without any letters
CustomFieldSetFormula FieldID:=pjCustomTaskNumber10, Formula:="[Remaining Work]/60"
CustomFieldRename FieldID:=pjCustomTaskNumber10, NewName:="Remaining Work Hrs"
CustomFieldPropertiesEx FieldID:=pjCustomTaskNumber10, Attribute:=pjFieldAttributeFormula, SummaryCalc:=pjCalcNone, GraphicalIndicators:=False, AutomaticallyRolldownToAssn:=False
'Create Start column in m/d/yy format
CustomFieldSetFormula FieldID:=pjCustomTaskText10, Formula:="format([Start],""m/dd/yyyy"")"
CustomFieldRename FieldID:=pjCustomTaskText10, NewName:="Start Formatted"
CustomFieldPropertiesEx FieldID:=pjCustomTaskText10, Attribute:=pjFieldAttributeFormula, SummaryCalc:=pjCalcNone, GraphicalIndicators:=False, AutomaticallyRolldownToAssn:=False
'Copy Project Tasks
SelectSheet
EditCopy
'--- EXCEL ---
On Error Resume Next 'ignore errors from Excel
'Schedule Sheet
'Prepare Excel File
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
xlBook.Sheets.Add
Set xlSheet = xlBook.Worksheets(1)
Set xlSheet2 = xlBook.Worksheets(2)
xlSheet2.Name = "Sheet3"
xlApp.Visible = False
'Paste Project Tasks into Excel
xlSheet.Range("b1").Select
xlSheet.Paste
Set xlRange = xlSheet.UsedRange
xlRange.WrapText = False
xlSheet.ListObjects.Add(xlSrcRange, xlRange, , xlYes).Name = "Table1"
'Insert icons
'Insert column with formula
xlSheet.Columns("h:h").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
xlSheet.Range("Table1[[#Headers],[Column1]]").Value = " "
xlSheet.Range("h2").Value = _
"=IF([@Active]=""No"",1" & _
",IF([@Status]=""Complete"",2" & _
",IF([@Status]=""Late"",3" & _
",IF(OR([@Status]=""Future Task"",[@Status]=""On Schedule""),4" & _
"))))"
'Configure conditional formatting
xlSheet.Range("Table1[[ ]]").Select
xlApp.Selection.FormatConditions.AddIconSetCondition
xlApp.Selection.FormatConditions(xlApp.Selection.FormatConditions.Count).SetFirstPriority
With xlApp.Selection.FormatConditions(1)
.ReverseOrder = False
.ShowIconOnly = True
.IconSet = xlBook.IconSets(xl4TrafficLights)
End With
xlApp.Selection.FormatConditions(1).IconCriteria(1).Icon = xlIconGrayCircle
With xlApp.Selection.FormatConditions(1).IconCriteria(2)
.Type = xlConditionValueNumber
.Value = 2
.Operator = 7
.Icon = xlIconGreenCheck
End With
With xlApp.Selection.FormatConditions(1).IconCriteria(3)
.Type = xlConditionValueNumber
.Value = 3
.Operator = 7
.Icon = xlIconRedFlag
End With
With xlApp.Selection.FormatConditions(1).IconCriteria(4)
.Type = xlConditionValueNumber
.Value = 4
.Operator = 7
.Icon = xlIconGreenCircle
End With
'Format Sheet
xlApp.ActiveWindow.DisplayGridlines = False
xlSheet.Columns("H:AA").EntireColumn.AutoFit
xlSheet.Columns("F:F").ColumnWidth = 55
xlSheet.Columns("F:F").WrapText = True
xlSheet.Columns("A:A").ColumnWidth = 27.22
xlSheet.Range("A1").Value = "Filters"
xlSheet.Range("B2").Select
xlApp.ActiveWindow.FreezePanes = True
'insert column for ID - Name
xlSheet.Columns("AC:AC").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
xlSheet.Range("Table1[[#Headers],[Column1]]").Value = "ID - Name"
xlSheet.Range("AC2").Value = "=TRIM(CONCATENATE([@ID],"" - "",[@Name],"" | "",TEXT([% Complete],""0%""),"" Complete | Planned Finish: "",[@Finish]))"
xlSheet.Columns("AA:AC").Hidden = True
With xlSheet.Range("A1")
.HorizontalAlignment = xlCenter
.Range("A1").Style = "Accent5"
.Font.Bold = True
End With
'Insert Slicers
xlBook.SlicerCaches.Add2(xlSheet.ListObjects("Table1"), "Summary"). _
Slicers.Add xlSheet, , "Summary", "Summary", _
15, 1, 75, 50
xlBook.SlicerCaches.Add2(xlSheet.ListObjects("Table1"), "Active"). _
Slicers.Add xlSheet, , "Active", "Active", _
15, 76, 75, 50
xlBook.SlicerCaches.Add2(xlSheet.ListObjects("Table1"), "Milestone" _
).Slicers.Add xlSheet, , "Milestone", "Milestone", _
65, 1, 75, 50
xlBook.SlicerCaches.Add2(xlSheet.ListObjects("Table1"), "Critical") _
.Slicers.Add xlSheet, , "Critical", "Critical", _
65, 76, 75, 50
xlBook.SlicerCaches.Add2(xlSheet.ListObjects("Table1"), "Status"). _
Slicers.Add xlSheet, , "Status", "Status", _
115, 1, 150, 70
xlBook.SlicerCaches.Add2(xlSheet.ListObjects("Table1"), _
"Outline Level").Slicers.Add xlSheet, , "Outline Level", "Outline Level", _
185, 1, 150, 90
'insert instructions to filter by resource
instrNotes = "HOW TO FIND TASKS BY RESOURCE" & vbNewLine & _
"1. Clear summary filter above to view subtasks." & vbNewLine & _
"2. Select dropdown menu from Resource Names column." & vbNewLine & _
"3. Type the name in the search field." & vbNewLine & _
"4. Click Ok." & vbNewLine & _
"5. Select dropdown menu from Resource Names column again." & vbNewLine & _
"6. Scroll to the bottom of list." & vbNewLine & _
"7. Select ""(blanks)""." & vbNewLine & _
"8. Click OK." & vbNewLine & vbNewLine & _
"- Now your subtasks and the summary tasks will appear in this schedule." & vbNewLine & _
"- You could also use the" & vbNewLine & _
"""Who Does What"" sheet."
xlSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
1, 276, 149, 205).Select
xlApp.Selection.ShapeRange.ShapeStyle = msoShapeStylePreset34
xlApp.Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 9
xlApp.Selection.Placement = xlFreeFloating
xlApp.Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = instrNotes
'Set Columns
xlBook.SlicerCaches("Slicer_Status").Slicers("Status").NumberOfColumns = 2
xlBook.SlicerCaches("Slicer_Critical").Slicers("Critical").NumberOfColumns = 2
xlBook.SlicerCaches("Slicer_Milestone").Slicers("Milestone").NumberOfColumns = 2
xlBook.SlicerCaches("Slicer_Active").Slicers("Active").NumberOfColumns = 2
xlBook.SlicerCaches("Slicer_Summary").Slicers("Summary").NumberOfColumns = 2
xlBook.SlicerCaches("Slicer_Outline_Level").Slicers("Outline Level").NumberOfColumns = 4
'Set to False
xlBook.SlicerCaches("Slicer_Active").SlicerItems("No").Selected = False
xlBook.SlicerCaches("Slicer_Summary").SlicerItems("No").Selected = False
xlBook.SlicerCaches("Slicer_Status").SlicerItems("Complete").Selected = False
'Sort to be Yes, No
xlBook.SlicerCaches("Slicer_Summary").SortItems = xlSlicerSortDescending
xlBook.SlicerCaches("Slicer_Active").SortItems = xlSlicerSortDescending
xlBook.SlicerCaches("Slicer_Milestone").SortItems = xlSlicerSortDescending
xlBook.SlicerCaches("Slicer_Critical").SortItems = xlSlicerSortDescending
'WHO DOES WHAT sheet- EXCEL
'Create PivotTable
xlSheet.Range("b4").Select
xlBook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Table1", Version:=xlPivotTableVersion15).CreatePivotTable TableDestination _
:="Sheet3!R4C1", TableName:="PivotTable2", DefaultVersion:= _
xlPivotTableVersion15
With xlSheet2.PivotTables("PivotTable2").PivotFields("Resource Names")
.Orientation = xlPageField
.Position = 1
End With
With xlSheet2.PivotTables("PivotTable2").PivotFields("Start Formatted")
.Orientation = xlRowField
.Position = 1
End With
With xlSheet2.PivotTables("PivotTable2").PivotFields("ID - Name")
.Orientation = xlRowField
.Position = 2
End With
xlSheet2.PivotTables("PivotTable2").AddDataField xlSheet2.PivotTables( _
"PivotTable2").PivotFields("Remaining Work Hrs"), "Remaining Work Hrs ", xlSum
xlSheet2.PivotTables("PivotTable2").CompactLayoutRowHeader = _
"Task ID - Task Name"
'Group PivotTable Dates and collapse to level 1
xlSheet2.Activate
xlSheet2.Range("A5").Select
xlApp.Selection.Group Start:=True, End:=True, Periods:=Array(False, False, False, _
True, True, False, False)
xlBook.ShowPivotTableFieldList = False
xlSheet2.PivotTables("PivotTable2").HasAutoFormat = False
xlSheet2.PivotTables("PivotTable2").PivotFields("Start").ShowDetail = False
'Create timeline
xlSheet2.Rows("1:1").RowHeight = 120
xlBook.SlicerCaches.Add2(xlSheet2.PivotTables("PivotTable2"), _
"Start Formatted", , xlTimeline).Slicers.Add xlSheet2, , "Start 1", "Years", _
1, 1, 150, 108
xlSheet2.Shapes.Range(Array("Start 1")).Select
xlSheet2.Shapes.Range("Start 1").Duplicate.Select
xlBook.SlicerCaches("NativeTimeline_Start_Formatted").Slicers("Start 1"). _
TimelineViewState.Level = xlTimelineLevelYears
xlBook.SlicerCaches("NativeTimeline_Start_Formatted").Slicers("Start 1"). _
TimelineViewState.Level = xlTimelineLevelYears 'this doesn't always work the first time
xlBook.SlicerCaches("NativeTimeline_Start_Formatted").Slicers("Start 2").Caption _
= "Months"
xlSheet2.Shapes("Start 2").IncrementLeft 141
xlSheet2.Shapes("Start 2").IncrementTop -12
xlSheet2.Shapes("Start 2").ScaleWidth 3, msoFalse, msoScaleFromTopLeft
'Scroll timelines to left
xlBook.SlicerCaches("NativeTimeline_Start_Formatted").TimelineState.SetFilterDateRange _
Format(ActiveProject.ProjectStart, "mm/dd/yyyy"), _
Format(DateAdd("m", 1, ActiveProject.ProjectStart), "mm/dd/yyyy")
xlBook.SlicerCaches("NativeTimeline_Start_Formatted").ClearDateFilter
xlSheet2.PivotTables("PivotTable2").PivotFields("Months").ShowDetail = False
xlSheet2.Columns("A:A").ColumnWidth = 111.44
'Create slicers
'Active
xlBook.SlicerCaches.Add2(xlSheet2.PivotTables("PivotTable2"), _
"Active").Slicers.Add xlSheet2, , "Active 1", "Active", _
1, 607, 75, 50
xlBook.SlicerCaches("Slicer_Active1").Slicers("Active 1").NumberOfColumns = 2
xlBook.SlicerCaches("Slicer_Active1").SlicerItems("No").Selected = False
xlBook.SlicerCaches("Slicer_Active1").SortItems = xlSlicerSortDescending
'Summary
xlBook.SlicerCaches.Add2(xlSheet2.PivotTables("PivotTable2"), _
"Summary").Slicers.Add xlSheet2, , "Summary 2", "Summary", _
1, 680, 75, 50
xlBook.SlicerCaches("Slicer_Summary1").Slicers("Summary 2").NumberOfColumns = 2
xlBook.SlicerCaches("Slicer_Summary1").SlicerItems("Yes").Selected = False
xlBook.SlicerCaches("Slicer_Summary1").SortItems = xlSlicerSortDescending
'Status
xlBook.SlicerCaches.Add2(xlSheet2.PivotTables("PivotTable2"), _
"Status").Slicers.Add xlSheet2, , "Status 1", "Status", _
1, 755, 300, 50
xlBook.SlicerCaches("Slicer_Status1").Slicers("Status 1").NumberOfColumns = 4
xlBook.SlicerCaches("Slicer_Status1").SlicerItems("Complete").Selected = False
'Resource Slicer
xlBook.SlicerCaches.Add2(xlSheet2.PivotTables("PivotTable2"), _
"Resource Names").Slicers.Add xlSheet2, , "Resource Names 1", "Resource Names", _
55, 712, 343, 325
xlBook.SlicerCaches("Slicer_Resource_Names").Slicers("Resource Names 1").NumberOfColumns = 2
'Insert instructions to use filter
With xlSheet2.Range("b2").Interior
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0
End With
xlSheet2.Range("b2").Font.ThemeColor = xlThemeColorDark1
xlSheet2.Shapes.AddTextbox(msoTextOrientationHorizontal, _
607, 65, 100, 48).Select
xlApp.Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"Select drop down below" & Chr(13) & _
"Type a name to search for" & Chr(13) & _
"""Select Multiple Items""" & Chr(13) & _
"Click Ok"
With xlApp.Selection.ShapeRange.TextFrame2
.TextRange.Font.Size = 8
.VerticalAnchor = msoAnchorBottom
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
End With
xlApp.Selection.ShapeRange.ShapeStyle = msoShapeStylePreset34
'Clean up Excel
xlApp.ActiveWindow.DisplayGridlines = False
xlSheet2.Range("a1").Select
xlSheet.Name = "Schedule"
xlSheet2.Name = "Who Does What When"
xlSheet.Activate
xlSheet.Range("a1").Select
'Clean Up Project
On Error GoTo ErrorHandler
RestoreOriginalSettings
UpdatesON
DoEvents
'Save As Dialog
projectName = ActiveProject.Tasks.UniqueID(0).Name & " - " & _
Format(Now(), "yyyy-mm-dd_HHmm")
xlApp.Visible = True
xlApp.Dialogs(xlDialogSaveAs).Show projectName
End
ErrorHandler:
HandlingErrors
End Sub