从excel生成包含主要任务和里程碑的MS项目文件
从excel生成包含主要任务和里程碑的MS项目文件
提问于 2019-03-05 16:10:16
我设法做了一个很好的脚本，可以从excel中选定的表格生成一个MS-project文件。我现在正在寻求帮助，让它变得更有用。我想在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应如下所示：
回答 1
Stack Overflow用户
回答已采纳
发布于 2019-03-07 02:45:43
以下是更新后的代码: 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页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/54998083
复制相关文章
相似问题
腾讯云开发者
