使用VBA的MS Project到Excel Gantt Chart

Question

我正在尝试使用Project中的VBA脚本将一些任务从MS Project导出到Excel。 到目前为止，我可以毫无问题地导出我想要的数据，并且可以在Excel中很好地打开它。 我现在想做的是在Excel中获取数据并将其复制到与Project中的甘特图相似的甘特图中。 我知道我知道，当我已经在Project中有一个正确的视图时，为了获得Excel中的甘特图而进行所有这些操作有什么意义？ 除此之外，还制作了此Excel甘特图，因此没有MS Project的每个人都可以在没有MS Project的情况下查看计划的任务。

因此，到目前为止，我已经尝试过（因为excel没有内置的甘特图制作工具）是在电子表格上制作图表，为单元格着色以模仿甘特图。 我的两个主要问题：1.我不知道如何根据开始的日期为每个特定任务添加偏移量。2.我不知道如何为正确数量的单元格上色（现在它为单元格中的单元格上色） 7的倍数，或一次为几周，而不是特定日期。

Sub ExportToExcel()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim proj As Project
Dim t As Task
Dim pj As Project
Dim i As Integer
Set pj = ActiveProject
Set xlApp = New Excel.Application
xlApp.Visible = True
AppActivate "Excel"
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Cells(1, 1).Value = "Project Name"
xlSheet.Cells(1, 2).Value = pj.Name
xlSheet.Cells(2, 1).Value = "Project Title"
xlSheet.Cells(2, 2).Value = pj.Title
xlSheet.Cells(4, 1).Value = "Task ID"
xlSheet.Cells(4, 2).Value = "Task Name"
xlSheet.Cells(4, 3).Value = "Task Start"
xlSheet.Cells(4, 4).Value = "Task Finish"

For Each t In pj.Tasks
    xlSheet.Cells(t.ID + 4, 1).Value = t.ID
    xlSheet.Cells(t.ID + 4, 2).Value = t.Name
    xlSheet.Cells(t.ID + 4, 3).Value = t.Start
    xlSheet.Cells(t.ID + 4, 4).Value = t.Finish

    Dim x As Integer
    'x is the duration of task in days(i.e. half a day long task is 0.5)
    x = t.Finish - t.Start
    'Loop to add day of week headers and color cells to mimic Gantt chart
    For i = 0 To x
        xlSheet.Cells(4, (7 * i) + 5).Value = "S"
        xlSheet.Cells(4, (7 * i) + 6).Value = "M"
        xlSheet.Cells(4, (7 * i) + 7).Value = "T"
        xlSheet.Cells(4, (7 * i) + 8).Value = "W"
        xlSheet.Cells(4, (7 * i) + 9).Value = "T"
        xlSheet.Cells(4, (7 * i) + 10).Value = "F"
        xlSheet.Cells(4, (7 * i) + 11).Value = "S"

        xlSheet.Cells(t.ID + 4, ((7 * i) + 5)).Interior.ColorIndex = 37
        xlSheet.Cells(t.ID + 4, (7 * i) + 6).Interior.ColorIndex = 37
        xlSheet.Cells(t.ID + 4, (7 * i) + 7).Interior.ColorIndex = 37
        xlSheet.Cells(t.ID + 4, (7 * i) + 8).Interior.ColorIndex = 37
        xlSheet.Cells(t.ID + 4, (7 * i) + 9).Interior.ColorIndex = 37
        xlSheet.Cells(t.ID + 4, (7 * i) + 10).Interior.ColorIndex = 37
        xlSheet.Cells(t.ID + 4, (7 * i) + 11).Interior.ColorIndex = 37
    Next i
Next t
End Sub

Excel中当前MS项目输出的屏幕截图

如果有人有更好的建议，请告诉我。 我对此很陌生，不知道这是否可能，或者是否可能并且如此复杂，以至于都不值得。

Answer 1

可能，我有一个做多年的宏指令。 使用下面的代码。

Sub ExportToExcel()

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim proj As Project
Dim t As Task
Dim pj As Project
Dim pjDuration As Integer
Dim i As Integer
Set pj = ActiveProject
Set xlApp = New Excel.Application
xlApp.Visible = True
'AppActivate "Excel"
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
xlSheet.cells(1, 1).Value = "Project Name"
xlSheet.cells(1, 2).Value = pj.Name
xlSheet.cells(2, 1).Value = "Project Title"
xlSheet.cells(2, 2).Value = pj.Title
xlSheet.cells(1, 4).Value = "Project Start"
xlSheet.cells(1, 5).Value = pj.ProjectStart
xlSheet.cells(2, 4).Value = "Project Finish"
xlSheet.cells(2, 5).Value = pj.ProjectFinish

xlSheet.cells(1, 7).Value = "Project Duration"
pjDuration = pj.ProjectFinish - pj.ProjectStart
xlSheet.cells(1, 8).Value = pjDuration & "d"

xlSheet.cells(4, 1).Value = "Task ID"
xlSheet.cells(4, 2).Value = "Task Name"
xlSheet.cells(4, 3).Value = "Task Start"
xlSheet.cells(4, 4).Value = "Task Finish"

' Add day of the week headers for the entire Project's duration
For i = 0 To pjDuration
    xlSheet.cells(4, i + 5).Value = pj.ProjectStart + i
    xlSheet.cells(4, i + 5).NumberFormat = "[$-409]d-mmm-yy;@"
Next

For Each t In pj.Tasks
    xlSheet.cells(t.ID + 4, 1).Value = t.ID
    xlSheet.cells(t.ID + 4, 2).Value = t.Name
    xlSheet.cells(t.ID + 4, 3).Value = t.Start
    xlSheet.cells(t.ID + 4, 3).NumberFormat = "[$-409]d-mmm-yy;@"
    xlSheet.cells(t.ID + 4, 4).Value = t.Finish
    xlSheet.cells(t.ID + 4, 4).NumberFormat = "[$-409]d-mmm-yy;@"

    For i = 5 To pjDuration + 5
        'Loop to add day of week headers and color cells to mimic Gantt chart
        If t.Start <= xlSheet.cells(4, i) And t.Finish >= xlSheet.cells(4, i) Then
            xlSheet.cells(t.ID + 4, i).Interior.ColorIndex = 37
        End If
     Next i
Next t