生成包含来自excel的主要任务和里程碑的MS项目文件

Question

我设法制作了一个很好的脚本，可以从excel中的选定表生成一个MS项目文件。我现在正在寻求帮助，使它更有用。我想在excel中的特定表中的每个主要任务下插入里程碑。每个主要任务都有一个相应的里程碑表。

Sub MSPexport()

Dim pjapp As Object
Dim strValue, strWorktime, strMilestone As String
Dim newproj
Set pjapp = CreateObject("MSProject.application") 

If pjapp Is Nothing Then
MsgBox "Project is not installed"
End
End If

pjapp.Visible = True
Set newproj = pjapp.Projects.Add
Set ActiveProject = newproj

pjapp.NewTasksStartOn

'insert tasks here

 For I = 3 To 8 'currently I am pointing to the range A3:A:8 - would like to make it a named range instead - ie "Maintasks" - how to do this?

    strValue = Worksheets("Planning").Range("A" & I)
    newproj.Tasks.Add (strValue)

    'Insert predecessor if not first task
    If I <> 3 Then
      newproj.Tasks(I - 2).Predecessors = (I - 3)
    End If

    'here I would like to insert milestones as subtasks

    For M = 3 to 5 ' this I also would like to be a named range and also I need to check for or lookup the correct main task and the corresponding milestone list
      strMilestone = Worksheets("Milestones").Range("C" & M)
        newproj.Tasks.Add (strMilestone)
        newproj.Tasks(M - 2).Duration = 0
        newproj.Tasks(M - 2).OutlineIndent
        newproj.Tasks(M - 2).Predecessors = (I - 26)
    Next M   
Next I

End Sub

完成后，MS-Project应如下所示：

Answer 1

以下是更新为1）使用命名范围的代码，以及2）插入里程碑：

Sub MSPexport()

Dim pjapp As Object
Dim newproj As Object

Set pjapp = CreateObject("MSProject.application")
If pjapp Is Nothing Then
    MsgBox "Project is not installed"
    Exit Sub
End If
pjapp.Visible = True
Set newproj = pjapp.Projects.Add
pjapp.NewTasksStartOn

Dim rngMain As Range
Set rngMain = ActiveWorkbook.Names("Maintasks").RefersToRange
Dim MainTask As Range
Dim tskPredTaskMain As Object

For Each MainTask In rngMain.Cells
    Dim tskSummary As Object
    Set tskSummary = newproj.Tasks.Add(MainTask.Value)
    tskSummary.OutlineLevel = 1

    Dim rngMS As Range
    Set rngMS = ActiveWorkbook.Names(MainTask.Value & "_Milestones").RefersToRange
    Dim Milestone As Range
    Dim tskPredTaskMS As Object
    Set tskPredTaskMS = Nothing

    For Each Milestone In rngMS
        Dim tskMS As Object
        Set tskMS = newproj.Tasks.Add(Milestone.Value)
        ' use duration stored in days in column to the right
        tskMS.Duration = Milestone.Offset(, 1).Value * 8 * 60
        tskMS.OutlineLevel = 2

        If Not tskPredTaskMS Is Nothing Then
            tskMS.Predecessors = tskPredTaskMS.ID
        End If
        Set tskPredTaskMS = tskMS

    Next Milestone

    If Not tskPredTaskMain Is Nothing Then
        tskSummary.Predecessors = tskPredTaskMain.ID
    End If
    Set tskPredTaskMain = tskSummary

Next MainTask

End Sub